raster_2.3-0_(2014-9-5_by_Robert-J.-Hijmans-[cre,-aut],)
Table of Contents
- 1. AAAClasses.R
- 2. addFiles.R
- 3. addLayer.R
- 4. adjacency.R
- 5. adjacent.R
- 6. aggregate_3d.R
- 7. aggregate_old.R
- 8. aggregate.R
- 9. aggregate_sp.R
- 10. alignExtent.R
- 11. animate.R
- 12. approxNA.R
- 13. area.R
- 14. arith_sp.R
- 15. artith.R
- 16. as.array.R
- 17. as.data.frame.R
- 18. as.logical.R
- 19. as.matrix.R
- 20. as.raster.R
- 21. as.spatial.R
- 22. atan2.R
- 23. bands.R
- 24. barplot.R
- 25. bbox.R
- 26. bilinearValue.R
- 27. bind.R
- 28. blend.R
- 29. blockSize.R
- 30. boundaries.R
- 31. boxplot.R
- 32. brick.R
- 33. buffer.R
- 34. calc.R
- 35. canProcessInMemory.R
- 36. cellFromLine.R
- 37. cellFromPolygon.R
- 38. cellRowCol.R
- 39. cellsFromExtent.R
- 40. cellStats.R
- 41. cellValues.R
- 42. clamp.R
- 43. clearValues.R
- 44. click.R
- 45. clump.R
- 46. clusterR.R
- 47. coerce.R
- 48. commonDataType.R
- 49. compareCRS.R
- 50. compare_Logical.R
- 51. compare.R
- 52. connection.R
- 53. contour.R
- 54. corLocal.R
- 55. cor.R
- 56. coverBrick.R
- 57. coverPolygons.R
- 58. cover.R
- 59. crop.R
- 60. cropSpatial.R
- 61. crosstab.R
- 62. cut.R
- 63. cv.R
- 64. dataProperties.R
- 65. dataType.R
- 66. density.R
- 67. destair.R
- 68. detectCores.R
- 69. dim.R
- 70. direction.R
- 71. disaggregate.R
- 72. distanceFromPoints.R
- 73. distance.R
- 74. distanceRows.R
- 75. dotdens.R
- 76. drawExtent.R
- 77. drawPoly.R
- 78. drivers.R
- 79. dropLayer.R
- 80. erase.R
- 81. extend.R
- 82. extension.R
- 83. extent.R
- 84. extentUnion.R
- 85. extractExtent.R
- 86. extractLines.R
- 87. extractPoints.R
- 88. extractPolygons.R
- 89. extract.R
- 90. factor.R
- 91. filler.R
- 92. fixDBFnames.R
- 93. flip.R
- 94. flowpath.R
- 95. focalFun.R
- 96. focal.R
- 97. focalWeight.R
- 98. fourCellsFromXY.R
- 99. frbind.R
- 100. freq.R
- 101. fullFileName.R
- 102. gainoffset.R
- 103. gdalFormats.R
- 104. gdal.R
- 105. GDALtransient.R
- 106. Geary.R
- 107. getData.R
- 108. getValuesBlock.R
- 109. getValuesFocal.R
- 110. getValues.R
- 111. getValuesRows.R
- 112. gridDistance2.R
- 113. gridDistance.R
- 114. hdrBIL.R
- 115. hdrBov.R
- 116. hdrEnvi.R
- 117. hdrErdasRaw.R
- 118. hdrIDRISI.R
- 119. hdrPRJ.R
- 120. hdr.R
- 121. hdrRaster.R
- 122. hdrSAGA.R
- 123. hdrVRT.R
- 124. hdrWorldFile.R
- 125. head.R
- 126. hillShade.R
- 127. hist.R
- 128. idwValue.R
- 129. imageplot2.R
- 130. imageplot.R
- 131. image.R
- 132. index.R
- 133. indexReplaceBrick.R
- 134. indexReplace.R
- 135. inifile.R
- 136. init.R
- 137. intDataType.R
- 138. interpolate.R
- 139. intersect.R
- 140. intersect_sp.R
- 141. isLonLat.R
- 142. is.na.R
- 143. kernelDens.R
- 144. kml_multiple.R
- 145. kml.R
- 146. layerize.R
- 147. layerStats.R
- 148. makeProjString.R
- 149. makeRasterList.R
- 150. mask.R
- 151. match.R
- 152. math.R
- 153. maxDataType.R
- 154. mean.R
- 155. merge.R
- 156. metadata.R
- 157. minValue.R
- 158. modal.R
- 159. modalRaster.R
- 160. moran.R
- 161. mosaic.R
- 162. movingFun.R
- 163. multiCore.R
- 164. names.R
- 165. naValue.R
- 166. ncell.R
- 167. netCDFreadCells.R
- 168. netCDFread.R
- 169. netCDFtoRasterCD.R
- 170. netCDFtoRasterGMT.R
- 171. netCDFtoStack.R
- 172. netCDFutil.R
- 173. netCDFwriteCD.R
- 174. newPLot.R
- 175. nlayers.R
- 176. notused.R
- 177. nsidcICE.R
- 178. origin.R
- 179. overlay.R
- Package: raster
- Type: Package
- Title: raster: Geographic data analysis and modeling
- Version: 2.3-0
- Date: 2014-9-5
- Depends: methods, sp (>= 1.0-13), R (>= 2.15.0)
- Suggests: rgdal (>= 0.8-12), rgeos (>= 0.3-1), ncdf, ncdf4, igraph,
- snow, tcltk, rasterVis
- Authors@R: c(
- person(“Robert J.”, “Hijmans”, role = c(“cre”, “aut”), email = “r.hijmans@gmail.com”),
- person(“Jacob”, “van Etten”, role = “ctb”),
- person(“Matteo”, “Mattiuzzi”, role = “ctb”),
- person(“Michael”, “Sumner”, role = “ctb”),
- person(“Jonathan A.”, “Greenberg”, role = “ctb”),
- person(“Oscar”, “Perpinan Lamigueiro”, role = “ctb”),
- person(“Andrew”, “Bevan”, role = “ctb”),
- person(“Etienne B.”, “Racine”, role = “ctb”),
- person(“Ashton”, “Shortridge”, role = “ctb”))
- Description: Reading, writing, manipulating, analyzing and modeling of gridded spatial data. The package implements basic and high-level functions. Processing of very large files is supported.
- License: GPL (>= 3)
- URL: http://cran.r-project.org/web/packages/raster/
- ByteCompile: TRUE
- Author: Robert J. Hijmans [cre, aut],
- Jacob van Etten [ctb],
- Matteo Mattiuzzi [ctb],
- Michael Sumner [ctb],
- Jonathan A. Greenberg [ctb],
- Oscar Perpinan Lamigueiro [ctb],
- Andrew Bevan [ctb],
- Etienne B. Racine [ctb],
- Ashton Shortridge [ctb]
- Maintainer: Robert J. Hijmans <r.hijmans@gmail.com>
- Repository: CRAN
- Repository/R-Forge/Project: raster
- Repository/R-Forge/Revision: 3030
- Repository/R-Forge/DateTimeStamp: 2014-09-05 16:47:51
- Date/Publication: 2014-09-06 08:07:38
- Packaged: 2014-09-05 18:16:14 UTC; rforge
- NeedsCompilation: yes
1 AAAClasses.R
# R classes for raster (grid) type spatial data # Robert J. Hijmans, r.hijmans@gmail.com # November 2008 # Version 1.0 # Licence GPL v3 setClass('Extent', representation ( xmin = 'numeric', xmax = 'numeric', ymin = 'numeric', ymax = 'numeric' ), prototype ( xmin = 0, xmax = 1, ymin = 0, ymax = 1 ), validity = function(object) { c1 <- (object@xmin <= object@xmax) if (!c1) { stop('invalid extent: xmin >= xmax') } c2 <- (object@ymin <= object@ymax) if (!c2) { stop('invalid extent: ymin >= ymax') } v <- c(object@xmin, object@xmax, object@ymin, object@ymax) c3 <- all(!is.infinite(v)) if (!c3) { stop('invalid extent: infinite value') } return(c1 & c2 & c3) } ) setClass('.Rotation', representation ( geotrans = 'numeric', transfun = 'function' ) ) setClass ('BasicRaster', representation ( title = 'character', extent = 'Extent', rotated = 'logical', rotation = '.Rotation', ncols ='integer', nrows ='integer', crs = 'CRS', history = 'list', #meta = 'list', z = 'list' ), prototype ( rotated = FALSE, ncols= as.integer(1), nrows= as.integer(1), crs = CRS(), history = list(), #meta = list(), z = list() ), validity = function(object) { validObject(extent(object)) c1 <- (object@ncols > 0) if (!c1) { stop('ncols < 1') } c2 <- (object@nrows > 0) if (!c2) { stop('nrows < 1') } return(c1 & c2) } ) setClass ('Raster', contains = c('BasicRaster', 'VIRTUAL') ) setClass('.RasterFile', representation ( name ='character', datanotation='character', byteorder ='character', nodatavalue ='numeric', # on disk, in ram it is NA NAchanged ='logical', nbands ='integer', bandorder ='character', offset='integer', toptobottom='logical', blockrows='integer', blockcols='integer', driver ='character', open = 'logical' ), prototype ( name = '', datanotation='FLT4S', byteorder = .Platform$endian, nodatavalue = -Inf, NAchanged = FALSE, nbands = as.integer(1), bandorder = 'BIL', offset = as.integer(0), toptobottom = TRUE, blockrows = as.integer(0), blockcols= as.integer(0), driver = '', open = FALSE ), validity = function(object) { c1 <- datanotation %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S') return(c1) } ) setClass('.SingleLayerData', representation ( values='vector', offset='numeric', gain='numeric', inmemory='logical', fromdisk='logical', isfactor = 'logical', attributes = 'list', haveminmax = 'logical', min = 'vector', max = 'vector', band = 'integer', unit = 'character', names = 'vector' ), prototype ( values=vector(), offset=0, gain=1, inmemory=FALSE, fromdisk=FALSE, isfactor = FALSE, attributes = list(), haveminmax = FALSE, min = c(Inf), max = c(-Inf), band = as.integer(1), unit = '', names=c() ), validity = function(object) { } ) setClass ('.RasterLegend', representation ( type = 'character', values = 'vector', color = 'vector', names = 'vector', colortable = 'vector' ), prototype ( ) ) setClass ('RasterLayer', contains = 'Raster', representation ( file = '.RasterFile', data = '.SingleLayerData', legend = '.RasterLegend' ) ) setClass('.MultipleRasterData', representation ( values='matrix', offset='numeric', gain='numeric', inmemory='logical', fromdisk='logical', nlayers='integer', dropped = 'vector', isfactor = 'logical', attributes = 'list', haveminmax = 'logical', min = 'vector', max = 'vector', unit = 'vector', names= 'vector' ), prototype ( values=matrix(NA,0,0), offset=0, gain=1, #indices =vector(mode='numeric'), inmemory=FALSE, fromdisk=FALSE, nlayers=as.integer(0), dropped=NULL, isfactor = FALSE, attributes = list(), haveminmax = FALSE, min = c(Inf), max = c(-Inf), unit = c(''), names = c('') ), validity = function(object) { } ) setClass ('RasterBrick', contains = 'Raster', representation ( file = '.RasterFile', data = '.MultipleRasterData', legend = '.RasterLegend' ) ) setClass ('RasterStack', contains = 'Raster', representation ( filename ='character', layers ='list' ), prototype ( filename='', layers = list() ), validity = function(object) { if (length(object@layers) > 1) { cond <- compareRaster(object@layers, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE) } else { cond <- TRUE } return(cond) } ) setClassUnion(RasterStackBrick, c(RasterStack, RasterBrick)) setClass ('RasterLayerSparse', contains = 'RasterLayer', representation ( index = 'vector' ), prototype ( index = vector(mode='numeric') ) ) setClass ('.RasterBrickSparse', contains = 'RasterBrick', representation ( index = 'vector' ), prototype ( index = vector(mode='numeric') ) ) setClass ('.RasterQuad', contains = 'Raster', representation ( filename ='character', bricks ='list' ), prototype ( filename='', bricks = list() ), validity = function(object) { if (length(object@bricks) > 1) { test <- compareRaster(object@bricks, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE) } else { test <- TRUE } return(test) } ) #setClassUnion(RasterStackBrickList, c(RasterStack, RasterBrick, RasterList)) setClass ('.RasterList', contains = 'list', representation (), prototype (), validity = function(object) { s <- sapply(object, function(x) inherits(x, 'Raster')) return( sum(s) == length(s)) } )
2 addFiles.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .addFiles <- function(x, rasterfiles, bands=rep(1, length(rasterfiles))) { if (length(bands) == 1) { bands=rep(bands, length(rasterfiles)) } rasters <- list() for (i in 1:length(rasterfiles)) { if (bands[[i]] < 1) { r <- raster(rasterfiles[[i]], band=1) rasters <- c(rasters, r) if (nbands(r) > 1) { for (j in 2:nbands(r)) { r <- raster(rasterfiles[[i]], band=j) rasters <- c(rasters, r) } } } else { rasters <- c(rasters, raster(rasterfiles[[i]], FALSE, band=bands[[i]])) } } x <- addLayer(x, rasters) return(x) }
3 addLayer.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : September 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(addLayer)) { setGeneric(addLayer, function(x, ...) standardGeneric(addLayer)) } setMethod('addLayer', signature(x='Raster'), function(x, ...) { rasters <- .makeRasterList(...) if (! inherits(x, 'RasterStack')) { x <- stack(x) } if (length(rasters)==0) { return(x) } if (nlayers(x) > 0) { compareRaster(c(x, rasters)) } else if (length(rasters) > 1) { compareRaster(rasters) } vals <- sapply(rasters, hasValues) if (sum(vals) == 0 & nlayers(x) == 0) { vals[1] <- TRUE } if (sum(vals) != length(vals)) { warning('Cannot add a RasterLayer with no associated data in memory or on disk to a RasterStack') } rasters <- rasters[vals] if (nlayers(x) == 0) { r <- rasters[[1]] x@nrows <- r@nrows x@ncols <- r@ncols x@extent <- r@extent x@crs <- r@crs if (rotated(r)) { x@rotated = r@rotated x@rotation = r@rotation } nl <- 1 x@layers[nl] <- r rasters <- rasters[-1] if (length(rasters)==0) { return(x) } } x@layers <- c(x@layers, rasters) names(x) <- sapply(x@layers, names) return(x) } )
4 adjacency.R
# Author: Jacob van Etten jacobvanetten@yahoo.com # Date : January 2009 # Version 0.9 # Licence GPL v3 .cs <- function(a,b) { aRep <- rep(a,times=length(b)) cbind(aRep,as.integer(aRep+rep(b,each=length(a))),deparse.level=0) } .adjacency <- function(x, ...) { warning('function adjaceny is obsolete and will be removed from the raster package.\nUse function adjacent in stead') dots <- list(...) fromCells <- dots$fromCells toCells <- dots$toCells directions <- dots$directions if (is.character(directions)) { directions <- tolower(directions) } stopifnot(directions %in% c(4,8,16) | directions=='bishop') x <- raster(x) outerMeridianConnect <- .isGlobalLonLat(x) if (directions==bishop) { return(.adjBishop(x, fromCells, toCells, outerMeridianConnect)) } nCols <- ncol(x) nCells <- ncell(x) left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) right <- seq(2*nCols,nCells-nCols,by=nCols) upper <- 2:(nCols-1) lower <- seq((nCells-nCols+2),(nCells-1),by=1) upperleft <- 1 upperright <- nCols lowerleft <- nCells-nCols+1 lowerright <- nCells fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright)))) fromCellsUpper <- as.integer(intersect(fromCells,upper)) fromCellsLower <- as.integer(intersect(fromCells,lower)) fromCellsLeft <- as.integer(intersect(fromCells,left)) fromCellsRight <- as.integer(intersect(fromCells,right)) fromCellUpperleft <- as.integer(intersect(fromCells,upperleft)) fromCellUpperright <- as.integer(intersect(fromCells,upperright)) fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft)) fromCellLowerright <- as.integer(intersect(fromCells,lowerright)) rook <- c(1,-1,nCols,-nCols) coreFromToRook <- .cs(fromCellsCore,rook) upperFromToRook <- .cs(fromCellsUpper,rook[1:3]) lowerFromToRook <- .cs(fromCellsLower,rook[c(1,2,4)]) leftFromToRook <- .cs(fromCellsLeft,rook[c(1,3,4)]) rightFromToRook <- .cs(fromCellsRight,rook[2:4]) upperleftFromToRook <- .cs(fromCellUpperleft,rook[c(1,3)]) upperrightFromToRook <- .cs(fromCellUpperright,rook[2:3]) lowerleftFromToRook <- .cs(fromCellLowerleft,rook[c(1,4)]) lowerrightFromToRook <- .cs(fromCellLowerright,rook[c(2,4)]) fromto1 <- rbind(coreFromToRook,upperFromToRook,lowerFromToRook,leftFromToRook,rightFromToRook,upperleftFromToRook,upperrightFromToRook,lowerleftFromToRook,lowerrightFromToRook) if (outerMeridianConnect) { meridianFromLeft <- rbind( cbind(fromCellsLeft,as.integer(fromCellsLeft+nCols-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft+nCols-1)) ) meridianFromRight <- rbind( cbind(fromCellsRight,as.integer(fromCellsRight-nCols+1)), cbind(fromCellUpperright,as.integer(fromCellUpperright-nCols+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-nCols+1)) ) fromto1 <- rbind(fromto1,meridianFromLeft,meridianFromRight) } fromto <- subset(fromto1,fromto1[,2] %in% toCells) if (directions > 4) { bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1)) coreFromToBishop <- .cs(fromCellsCore,bishop) upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4]) lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2]) leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)]) rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)]) upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4]) upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3]) lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2]) lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1]) fromto2 <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop) if (outerMeridianConnect) { meridianFromLeft <- rbind( .cs(fromCellsLeft,c(2*nCols-1,-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1)) ) meridianFromRight <- rbind( cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))), cbind(fromCellUpperright,as.integer(fromCellUpperright+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1)) ) fromto2 <- rbind(fromto2,meridianFromLeft,meridianFromRight) } fromto2 <- subset(fromto2,fromto2[,2] %in% toCells) fromto <- rbind(fromto,fromto2) } if (directions > 8) { leftOuter <- seq(2*nCols+1,nCells-3*nCols+1,by=nCols) rightOuter <- seq(3*nCols,nCells-2*nCols,by=nCols) upperOuter <- seq(3,nCols-2,by=1) lowerOuter <- seq(nCells-nCols+3,nCells-2,by=1) upperleftUnder <- nCols+1 upperrightLeft <- nCols-1 lowerleftUp <- nCells-2*nCols+1 lowerrightUp <- nCells-nCols upperleftRight <- 2 upperrightUnder <- 2*nCols lowerleftRight <- nCells-nCols+2 lowerrightLeft <- nCells-1 leftInner <- seq(2*nCols+2,(nCells-3*nCols+2),by=nCols) rightInner <- seq(3*nCols-1,nCells-2*nCols-1,by=nCols) upperInner <- seq(nCols+3,2*nCols-2,by=1) lowerInner <- seq(nCells-2*nCols+3,nCells-nCols-2,by=1) upperleftInner <- nCols+2 upperrightInner <- 2*nCols-1 lowerleftInner <- nCells-2*nCols+2 lowerrightInner <- nCells-nCols-1 fromCellsCoreInner <- setdiff(fromCells,(c(leftOuter,rightOuter,upperOuter,lowerOuter,upperleft,upperright,lowerleft,lowerright, upperleftUnder, upperrightLeft, lowerleftUp, lowerrightUp, upperleftRight, upperrightUnder, lowerleftRight, lowerrightLeft, leftInner, rightInner, upperInner, lowerInner, upperleftInner, upperrightInner, lowerleftInner, lowerrightInner))) fromCellsUpperInner <- as.integer(intersect(fromCells,upperInner)) fromCellsLowerInner <- as.integer(intersect(fromCells,lowerInner)) fromCellsLeftInner <- as.integer(intersect(fromCells,leftInner)) fromCellsRightInner <- as.integer(intersect(fromCells,rightInner)) fromCellUpperleftInner <- as.integer(intersect(fromCells,upperleftInner)) fromCellUpperrightInner <- as.integer(intersect(fromCells,upperrightInner)) fromCellLowerleftInner <- as.integer(intersect(fromCells,lowerleftInner)) fromCellLowerrightInner <- as.integer(intersect(fromCells,lowerrightInner)) fromCellsLeftOuter <- as.integer(intersect(fromCells,leftOuter)) fromCellsRightOuter <- as.integer(intersect(fromCells,rightOuter)) fromCellsUpperOuter <- as.integer(intersect(fromCells,upperOuter)) fromCellsLowerOuter <- as.integer(intersect(fromCells,lowerOuter)) fromCellUpperleftUnder <- as.integer(intersect(fromCells,upperleftUnder)) fromCellUpperrightLeft <- as.integer(intersect(fromCells,upperrightLeft)) fromCellLowerleftUp <- as.integer(intersect(fromCells,lowerleftUp)) fromCellLowerrightUp <- as.integer(intersect(fromCells,lowerrightUp)) fromCellUpperleftRight <- as.integer(intersect(fromCells,upperleftRight)) fromCellUpperrightUnder <- as.integer(intersect(fromCells,upperrightUnder)) fromCellLowerleftRight <- as.integer(intersect(fromCells,lowerleftRight)) fromCellLowerrightLeft <- as.integer(intersect(fromCells,lowerrightLeft)) knight <- c(-2*nCols-1, -2*nCols+1, -nCols-2, -nCols+2, nCols-2, nCols+2, 2*nCols-1, 2*nCols+1) coreInnerFromToKnight <- .cs(fromCellsCoreInner, knight) upperInnerFromToKnight <- .cs(fromCellsUpperInner, knight[3:8]) lowerInnerFromToKnight <- .cs(fromCellsLowerInner, knight[1:6]) leftInnerFromToKnight <- .cs(fromCellsLeftInner, knight[c(1,2,4,6:8)]) rightInnerFromToKnight <- .cs(fromCellsRightInner, knight[c(1:3,5,7,8)]) upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knight[c(4,6:8)]) upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knight[c(3,5,7,8)]) lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knight[c(1,2,4,6)]) lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knight[c(1:3,5)]) leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knight[c(2,4,6,8)]) rightOuterFromToKnight <- .cs(fromCellsRightOuter, knight[c(1,3,5,7)]) upperOuterFromToKnight <- .cs(fromCellsUpperOuter, knight[5:8]) lowerOuterFromToKnight <- .cs(fromCellsLowerOuter, knight[1:4]) upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knight[c(4,6,8)]) upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knight[c(5,7,8)]) lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knight[c(2,4,6)]) lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knight[c(1,3,5)]) upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knight[6:8]) upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knight[c(3,5,7)]) lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knight[c(1,2,4)]) lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knight[1:3]) upperleftFromToKnight <- .cs(fromCellUpperleft, knight[c(6,8)]) upperrightFromToKnight <- .cs(fromCellUpperright, knight[c(5,7)]) lowerleftFromToKnight <- .cs(fromCellLowerleft, knight[c(2,4)]) lowerrightFromToKnight <- .cs(fromCellLowerright, knight[c(1,3)]) fromto3 <- rbind(coreInnerFromToKnight, upperInnerFromToKnight, lowerInnerFromToKnight, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperOuterFromToKnight, lowerOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight) fromto3 <- subset(fromto3,fromto3[,2] %in% toCells) if (outerMeridianConnect) { knightLeft <- c(-nCols-1, -2, +2*nCols-2, 3*nCols-1) knightRight <- c(-3*nCols+1, -2*nCols+2, +2, nCols+1) leftInnerFromToKnight <- .cs(fromCellsLeftInner, knightLeft[c(2,3)]) rightInnerFromToKnight <- .cs(fromCellsRightInner, knightRight[c(2,3)]) upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knightLeft[c(2,3)]) upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knightRight[c(2,3)]) lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knightLeft[c(2,3)]) lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knightRight[c(2,3)]) leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knightLeft) rightOuterFromToKnight <- .cs(fromCellsRightOuter, knightRight) upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knightLeft[2:4]) upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knightRight[3]) lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knightLeft[1:3]) lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knightRight[1:3]) upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knightLeft[c(3)]) upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knightRight[2:4]) lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knightLeft[2]) lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knightRight[2]) upperleftFromToKnight <- .cs(fromCellUpperleft, knightLeft[c(3,4)]) upperrightFromToKnight <- .cs(fromCellUpperright, knightRight[c(3,4)]) lowerleftFromToKnight <- .cs(fromCellLowerleft, knightLeft[c(1,2)]) lowerrightFromToKnight <- .cs(fromCellLowerright, knightRight[c(1,2)]) fromto3 <- rbind(fromto3, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight) } fromto3 <- subset(fromto3,fromto3[,2] %in% toCells) fromto <- rbind(fromto,fromto3) } colnames(fromto) <- c(from,to) return(fromto) } .adjBishop <- function(raster, fromCells, toCells, outerMeridianConnect) { nCols <- ncol(raster) nCells <- ncell(raster) left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) right <- seq(2*nCols,nCells-nCols,by=nCols) upper <- 2:(nCols-1) lower <- seq((nCells-nCols+2),(nCells-1),by=1) upperleft <- 1 upperright <- nCols lowerleft <- nCells-nCols+1 lowerright <- nCells fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright)))) fromCellsUpper <- as.integer(intersect(fromCells,upper)) fromCellsLower <- as.integer(intersect(fromCells,lower)) fromCellsLeft <- as.integer(intersect(fromCells,left)) fromCellsRight <- as.integer(intersect(fromCells,right)) fromCellUpperleft <- as.integer(intersect(fromCells,upperleft)) fromCellUpperright <- as.integer(intersect(fromCells,upperright)) fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft)) fromCellLowerright <- as.integer(intersect(fromCells,lowerright)) bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1)) coreFromToBishop <- .cs(fromCellsCore,bishop) upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4]) lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2]) leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)]) rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)]) upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4]) upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3]) lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2]) lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1]) fromto <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop) if (outerMeridianConnect) { meridianFromLeft <- rbind( .cs(fromCellsLeft,c(2*nCols-1,-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1)) ) meridianFromRight <- rbind( cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))), cbind(fromCellUpperright,as.integer(fromCellUpperright+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1)) ) fromto <- rbind(fromto,meridianFromLeft,meridianFromRight) } fromto <- subset(fromto,fromto[,2] %in% toCells) return(fromto) }
5 adjacent.R
# Author: Robert J. Hijmans # Date : September 2011 # Version 1.0 # Licence GPL v3 .adjacentUD <- function(x, cells, ngb, include) { # ngb should be a matrix with # one and only one cell with value 0 (the focal cell), # at least one cell with value 1 (the adjacent cells) # cells with other values are ignored (not considered adjacent) rs <- res(x) rn <- raster(ngb) center <- which(values(rn)==0) if (include) { ngb[center] <- 1 } rc <- rowFromCell(rn, center) cc <- colFromCell(rn, center) xngb <- yngb <- ngb xngb[] <- rep(1:ncol(ngb), each=nrow(ngb)) - cc yngb[] <- rep(nrow(ngb):1, ncol(ngb)) - (nrow(ngb)-rc+1) ngb[ngb != 1] <- NA xngb <- na.omit(as.vector( xngb * rs[1] * ngb)) yngb <- na.omit(as.vector( yngb * rs[2] * ngb)) xy <- xyFromCell(x, cells) X <- apply(xy[,1,drop=FALSE], 1, function(z) z + xngb ) Y <- apply(xy[,2,drop=FALSE], 1, function(z) z + yngb ) c(as.vector(X), as.vector(Y)) } adjacent <- function(x, cells, directions=4, pairs=TRUE, target=NULL, sorted=FALSE, include=FALSE, id=FALSE) { if (is.character(directions)) { directions <- tolower(directions) } x <- raster(x) r <- res(x) xy <- xyFromCell(x, cells) mat <- FALSE if (is.matrix(directions)) { stopifnot(length(which(directions==0)) == 1) stopifnot(length(which(directions==1)) > 0) d <- .adjacentUD(x, cells, directions, include) directions <- sum(directions==1, na.rm=TRUE) mat <- TRUE } else if (directions==4) { if (include) { d <- c(xy[,1], xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions==8) { if (include) { d <- c(xy[,1], rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1], xy[,2], rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1], rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions==16) { r2 <- r * 2 if (include) { d <- c(xy[,1], rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2), rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5), xy[,1], xy[,1], xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2), rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2), rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5), xy[,1], xy[,1], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2), rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions=='bishop') { if (include) { d <- c(xy[,1], rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2)) } else { d <- c(rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2)) } directions <- 4 # to make pairs } else { stop('directions should be one of: 4, 8, 16, bishop, or a matrix') } if (include) directions <- directions + 1 d <- matrix(d, ncol=2) if (.isGlobalLonLat(x)) { # normalize longitude to -180..180 d[,1] <- (d[,1] + 180) %% 360 - 180 } if (pairs) { if (mat) { cell <- rep(cells, each=directions) } else { cell <- rep(cells, directions) } if (id) { if (mat) { ID <- rep(1:length(cells), each=directions) } else { ID <- rep(1:length(cells), directions) } d <- na.omit(cbind(ID, cell, cellFromXY(x, d))) attr(d, 'na.action') <- NULL colnames(d) <- c('id', 'from', 'to') if (! is.null(target)) { d <- d[d[,3] %in% target, ] } } else { d <- na.omit(cbind(cell, cellFromXY(x, d))) attr(d, 'na.action') <- NULL colnames(d) <- c('from', 'to') if (! is.null(target)) { d <- d[d[,2] %in% target, ] } } if (sorted) { d <- d[order(d[,1], d[,2]),] } } else { d <- as.vector(unique(na.omit(cellFromXY(x, d)))) if (! is.null(target)) { d <- intersect(d, target) } if (sorted) { d <- sort(d) } } d }
6 aggregate_3d.R
# Author: Robert J. Hijmans # Date : July 2010 # Version 1.0 # Licence GPL v3 # October 2012: Major overhaul (including C interface) # November 2012: fixed bug with expand=F # June 2014: support for aggregation over z (layers) in addition to x and y setMethod('aggregate', signature(x='Raster'), function(x, fact=2, fun='mean', expand=TRUE, na.rm=TRUE, filename=, ...) { doC <- list(...)$doC if (is.null(doC)) { doC <- TRUE } nl <- nlayers(x) fact <- round(fact) lf <- length(fact) if (lf == 1) { fact <- c(fact, fact, 1) } else if (lf == 2) { fact <- c(fact, 1) } else if (lf > 3) { stop('fact should have length 1, 2, or 3') } if (nl < 2) { fact[3] <- 1 } if (any(fact < 1)) { stop('fact should be > 0') } if (! any(fact > 1)) { stop('fact should be > 1') } xfact <- fact[1] yfact <- fact[2] zfact <- fact[3] ncx <- ncol(x) nrx <- nrow(x) if (xfact > ncx) { warning('aggregation factor is larger than the number of columns') xfact <- ncx } if (yfact > nrx) { warning('aggregation factor is larger than the number of rows') yfact <- nrx } if (zfact > nl) { warning('aggregation factor is larger than the number of layers') zfact <- nl } addlyrs <- 0 if (expand) { rsteps <- as.integer(ceiling(nrx/yfact)) csteps <- as.integer(ceiling(ncx/xfact)) lsteps <- as.integer(ceiling(nl/zfact)) lastcol <- ncx lastrow <- nrx lastlyr <- lsteps * zfact if (lastlyr > nl ) { addlyrs <- lastlyr - nl } lyrs <- 1:nl #addcols <- csteps * xfact - ncx #addrows <- rsteps * yfact - nrx } else { rsteps <- as.integer(floor(nrx/yfact)) csteps <- as.integer(floor(ncx/xfact)) lsteps <- as.integer(floor(nl/zfact)) lastcol <- min(csteps * xfact, ncx) lastrow <- min(rsteps * yfact, nrx) lastlyr <- min(lsteps * zfact, nl) lyrs <- 1:lastlyr } ymn <- ymax(x) - rsteps * yfact * yres(x) xmx <- xmin(x) + csteps * xfact * xres(x) if (lsteps > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } extent(out) <- extent(xmin(x), xmx, ymn, ymax(x)) dim(out) <- c(rsteps, csteps, lsteps) ncout <- ncol(out) if (zfact == 1) { names(out) <- names(x) } if (! hasValues(x) ) { return(out) } fun <- .makeTextFun(fun) if (class(fun) == 'character') { op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1) } else { op <- NA } if (zfact > 1) { xyzfact <- xfact*yfact*zfact dims <- as.integer(c(lastrow, lastcol, nl+addlyrs, xfact, yfact, zfact)) if ( canProcessInMemory(x)) { v <- getValuesBlock(x, 1, lastrow, 1, lastcol, lyrs) if (addlyrs > 0) { add <- matrix(NA, nrow=nrow(v), ncol=addlyrs) v <- cbind(v, add) } v <- .Call(aggregate_get, as.double(v), as.integer(dims), PACKAGE='raster') v <- matrix(v, nrow=xyzfact) v <- apply(v, 2, fun, na.rm=na.rm) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { xx <- brick(x, values=FALSE) if (!expand) { nrow(xx) <- (nrow(x) %/% yfact) * yfact } tr <- blockSize(xx, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) tr$nrows[tr$n] <- nrow(xx) - tr$row[tr$n] + 1 tr$outrows <- ceiling(tr$nrows/yfact) pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { dims[1] <- as.integer(tr$nrows[i]) vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol, lyrs) if (addlyrs > 0) { add <- rep(NA, nrow(vals)*addlyrs) vals <- c(vals, add) } vals <- .Call(aggregate_get, as.double(vals), as.integer(dims), PACKAGE='raster') vals <- matrix(vals, nrow=xyzfact) vals <- apply(vals, 2, fun, na.rm=na.rm) out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } if (!is.na(op) & doC) { if ( canProcessInMemory(x)) { dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact)) x <- getValuesBlock(x, 1, lastrow, 1, lastcol) out <- setValues(out, .Call(aggregate, as.double(x), op, as.integer(na.rm), dims, PACKAGE='raster')) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { xx <- brick(x, values=FALSE) if (!expand) { nrow(xx) <- (nrow(x) %/% yfact) * yfact } tr <- blockSize(xx, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) tr$nrows[tr$n] <- nrow(xx) - tr$row[tr$n] + 1 tr$outrows <- ceiling(tr$nrows/yfact) pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact)) out <- writeStart(out, filename=filename, ...) if (inherits(out, 'RasterBrick')) { for (i in 1:tr$n) { dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i])) vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) vals <- .Call(aggregate, as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster') out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i])) vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) vals <- .Call(aggregate, as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster') out <- writeValues(out, vals, tr$write[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } # else not implemented in C if (nl < 2) { if (class(fun) == 'character') { rowcalc <- TRUE fun <- .getColFun(fun) } else { rowcalc <- FALSE } if ( canProcessInMemory(x)) { if (expand) { m <- ceiling(nrx / yfact) } else { m <- floor(nrx / yfact) } vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m) vend <- 0 vvstart <- 1 if (expand) { vals <- getValues(x) yf <- nrx %% yfact } else { vals <- getValuesBlock(x, 1, lastrow, 1, lastcol) yf <- 0 } for (j in 1:m) { if (j == m & yf > 0) { vstart <- vend + 1 vend <- vend + (lastcol * yf) mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE ) temp <- matrix(nrow=yf*xfact, ncol=csteps) temp[1:length(mv)] <- mv cols <- 1:(csteps) + (m-1) * csteps vv[1:nrow(temp), cols] <- temp } else { vstart <- vend + 1 vend <- vend + (lastcol * yfact) mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE ) vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv) vvstart <- vvstart + ncout*nrow(vv) } } if (rowcalc) { vals <- fun(vv, na.rm=na.rm ) } else { vals <- apply(vv, 2, fun, na.rm=na.rm ) } out <- setValues(out, as.vector(vals)) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(x, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) dif <- sum(tr$nrows) - nrow(x) if (dif > 0) { if (expand) { tr$nrows[tr$n] <- tr$nrows[tr$n] - dif } else { dif <- dif %/% xfact if (dif > 0) { tr$nrows[tr$n] <- dif * xfact } else { tr$n <- tr$n - 1 } } } pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) m <- tr$nrows[1] / yfact vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m) w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) for (i in 1:(tr$n-1)) { vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) vend <- 0 vvstart <- 1 for (j in 1:m) { vstart <- vend + 1 vend <- vend + (lastcol * yfact) mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE ) vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv) vvstart <- vvstart + ncout*nrow(vv) } if (rowcalc) { vals <- fun(vv, na.rm=na.rm ) } else { vals <- apply(vv, 2, fun, na.rm=na.rm ) } out <- writeValues(out, vals, tr$write[i]) pbStep(pb, i) } # if (i==tr$n) { i <- tr$n vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) m <- ceiling(tr$nrows[i] / yfact) vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m) vend <- 0 vvstart <- 1 yf <- tr$nrows[i] %% yfact for (j in 1:m) { if (j == m & yf > 0) { vstart <- vend + 1 vend <- vend + (lastcol * yf) mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE ) temp <- matrix(nrow=yf*xfact, ncol=csteps) temp[1:length(mv)] <- mv cols <- 1:(csteps) + (m-1) * csteps vv[1:nrow(temp), cols] <- temp } else { vstart <- vend + 1 vend <- vend + (lastcol * yfact) mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE ) vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv) vvstart <- vvstart + ncout*nrow(vv) } } if (rowcalc) { vals <- fun(vv, na.rm=na.rm ) } else { vals <- apply(vv, 2, fun, na.rm=na.rm ) } pbStep(pb, i) out <- writeValues(out, vals, tr$write[i]) pbClose(pb) x <- readStop(x) out <- writeStop(out) return(out) } } else { # nlayers > 1 if (canProcessInMemory(x, nlayers(x)+2)) { if (class(fun) == 'character') { op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1) } if (!is.na(op) & doC) { dim <- c(dim(x), dim(out)[1:2], xfact, yfact) v <- .Call(aggregate, as.double(getValues(x)), op, as.integer(na.rm), as.integer(dim), PACKAGE='raster') out <- setValues(out, matrix(v, ncol=dim[3])) return(out) } xx <- raster(x) x <- getValues(x) cols <- rep(rep(1:csteps, each=xfact)[1:ncol(xx)], times=nrow(xx)) rows <- rep(1:rsteps, each=ncol(xx) * yfact)[1:ncell(xx)] cells <- cellFromRowCol(xx, rows, cols) x <- as.matrix( aggregate(x, list(cells), fun, na.rm=na.rm ))[,-1] rm(cells) x <- setValues(out, x) if (filename != ) { x <- writeRaster(x, filename=filename, ...) } return(x) } else { cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact) rows <- rep(1, each=(ncol(x) * yfact)) out <- writeStart(out, filename=filename, ...) x <- readStart(x, ...) cells <- cellFromRowCol(x, rows, cols) nrows <- yfact w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) pb <- pbCreate(rsteps, label='aggregate', ...) for (r in 1:rsteps) { startrow <- 1 + (r - 1) * yfact if ( r==rsteps) { endrow <- min(nrow(x), startrow + yfact - 1) nrows <- endrow - startrow + 1 theserows <- (startrow * rows)[1:(ncol(x)*nrows)] cols <- cols[1:(ncol(x)*nrows)] cells <- cellFromRowCol(x, theserows, cols) } vals <- getValues(x, startrow, nrows) vals <- as.matrix( aggregate(vals, list(cells), fun, na.rm=na.rm ))[,-1] out <- writeValues(out, vals, r) pbStep(pb, r) } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } } ) #library(raster) #r <- raster(nc=9, nr=9) #r <- raster() #r[] = 1:ncell(r) #.aggtest(r, 5, 'min', doC=T) #aggregate(s, c(2,1,3), 'min', expand=F)
7 aggregate_old.R
# Author: Robert J. Hijmans # Date : July 2010 # Version 1.0 # Licence GPL v3 .aggregate_old <- function(x, fact=2, fun=mean, expand=TRUE, na.rm=TRUE, filename=, ...) { if (length(fact)==1) { fact <- as.integer(round(fact)) if (fact < 2) { stop('fact should be > 1') } xfact <- yfact <- fact } else if (length(fact)==2) { xfact <- as.integer(round(fact[[1]])) yfact <- as.integer(round(fact[[2]])) if (xfact < 2) { stop('fact[[1]] should be > 1') } if (yfact < 2) { stop('fact[[2]] should be > 1') } } else { stop('length(fact) should be 1 or 2') } if (xfact > ncol(x)) { warning('aggregation factor is larger than the number of columns') xfact <- ncol(x) } if (yfact > nrow(x)) { warning('aggregation factor is larger than the number of rows') yfact <- nrow(x) } if (expand) { rsteps <- as.integer(ceiling(nrow(x)/yfact)) csteps <- as.integer(ceiling(ncol(x)/xfact)) lastcol <- x@ncols lastrow <- x@nrows } else { rsteps <- as.integer(floor(nrow(x)/yfact)) csteps <- as.integer(floor(ncol(x)/xfact)) lastcol <- min(csteps * xfact, x@ncols) lastrow <- min(rsteps * yfact, x@nrows) } ymn <- ymax(x) - rsteps * yfact * yres(x) xmx <- xmin(x) + csteps * xfact * xres(x) nl <- nlayers(x) if (nl > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } extent(out) <- extent(xmin(x), xmx, ymn, ymax(x)) dim(out) <- c(rsteps, csteps) names(out) <- names(x) if (! hasValues(x) ) { return(out) } if (nl < 2) { fun <- .makeTextFun(fun) if (class(fun) == 'character') { rowcalc <- TRUE fun <- .getRowFun(fun) } else { rowcalc <- FALSE } if (! canProcessInMemory(x)) { if (filename == '') { filename <- rasterTmpFile() } } if (filename == '') { v <- matrix(NA, ncol=nrow(out), nrow=ncol(out)) } else { out <- writeStart(out, filename=filename, ...) } pb <- pbCreate(rsteps, ...) #vv <- matrix(ncol= csteps * yfact, nrow=rsteps * xfact) vv <- matrix(nrow= yfact * xfact, ncol=csteps) w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) for (r in 1:rsteps) { startrow <- 1 + (r - 1) * yfact vals <- getValuesBlock(x, startrow, yfact, 1, lastcol) if (r==rsteps) { endrow <- min(x@nrows, (startrow + yfact - 1)) nrows <- endrow - startrow + 1 vals <- matrix(vals, nrow=nrows, byrow=TRUE ) vv[] <- NA vvv <- vv[1:(nrows*xfact), ,drop=FALSE] vvv[1:length(vals)] <- vals vv[1:nrow(vvv),] <- vvv } else { vals <- matrix(vals, nrow=yfact, byrow=TRUE ) vv[1:length(vals)] = vals } if (rowcalc) { vals <- fun(t(vv), na.rm=na.rm ) } else { vals <- apply(vv, 2, fun, na.rm=na.rm ) } if (filename == ) { v[, r] <- vals } else { out <- writeValues(out, vals, r) } pbStep(pb, r) } pbClose(pb) if (filename == ) { values(out) <- as.vector(v) } else { out <- writeStop(out) } return(out) } else { # nlayers > 1 if (canProcessInMemory(x, nlayers(x)+2)) { xx <- raster(x) x <- getValues(x) cols <- rep(rep(1:csteps, each=xfact)[1:ncol(xx)], times=nrow(xx)) rows <- rep(1:rsteps, each=ncol(xx) * yfact)[1:ncell(xx)] cells <- cellFromRowCol(xx, rows, cols) x <- as.matrix( aggregate(x, list(cells), fun, na.rm=na.rm ))[,-1] rm(cells) x <- setValues(out, x) if (filename != ) { x <- writeRaster(x, filename=filename, ...) } return(x) } else { cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact) rows <- rep(1, each=(ncol(x) * yfact)) cells <- cellFromRowCol(x, rows, cols) nrows <- yfact w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) out <- writeStart(out, filename=filename, ...) pb <- pbCreate(rsteps, ...) for (r in 1:rsteps) { startrow <- 1 + (r - 1) * yfact if ( r==rsteps) { endrow <- min(nrow(x), startrow + yfact - 1) nrows <- endrow - startrow + 1 theserows <- (startrow * rows)[1:(ncol(x)*nrows)] cols <- cols[1:(ncol(x)*nrows)] cells <- cellFromRowCol(x, theserows, cols) } vals <- getValues(x, startrow, nrows) vals <- as.matrix( aggregate(vals, list(cells), fun, na.rm=na.rm ))[,-1] out <- writeValues(out, vals, r) pbStep(pb, r) } pbClose(pb) out <- writeStop(out) return(out) } } }
8 aggregate.R
# Author: Robert J. Hijmans # Date : July 2010 # Version 1.0 # Licence GPL v3 # October 2012: Major overhaul (including C interface) # November 2012: fixed bug with expand=F setMethod('aggregate', signature(x='Raster'), function(x, fact=2, fun='mean', expand=TRUE, na.rm=TRUE, filename=, ...) { doC <- list(...)$doC if (is.null(doC)) { doC <- TRUE } fact <- rep(as.integer(round(fact)), length.out=2) xfact <- fact[1] yfact <- fact[2] if (xfact < 1 | yfact < 1) { stop('fact should be > 0') } if (xfact < 2 & yfact < 2) { stop('fact[1] or fact[2] should be > 1') } if (xfact > ncol(x)) { warning('aggregation factor is larger than the number of columns') xfact <- ncol(x) } if (yfact > nrow(x)) { warning('aggregation factor is larger than the number of rows') yfact <- nrow(x) } ncx <- ncol(x) nrx <- nrow(x) if (expand) { rsteps <- as.integer(ceiling(nrx/yfact)) csteps <- as.integer(ceiling(ncx/xfact)) lastcol <- x@ncols lastrow <- x@nrows #addcols <- csteps * xfact - ncx #addrows <- rsteps * yfact - nrx } else { rsteps <- as.integer(floor(nrx/yfact)) csteps <- as.integer(floor(ncx/xfact)) lastcol <- min(csteps * xfact, x@ncols) lastrow <- min(rsteps * yfact, x@nrows) } ymn <- ymax(x) - rsteps * yfact * yres(x) xmx <- xmin(x) + csteps * xfact * xres(x) nl <- nlayers(x) if (nl > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } extent(out) <- extent(xmin(x), xmx, ymn, ymax(x)) dim(out) <- c(rsteps, csteps) names(out) <- names(x) ncout <- ncol(out) if (! hasValues(x) ) { return(out) } fun <- .makeTextFun(fun) if (class(fun) == 'character') { op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1) } else { op <- NA } if (!is.na(op) & doC) { if ( canProcessInMemory(x)) { dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact)) x <- getValuesBlock(x, 1, lastrow, 1, lastcol) out <- setValues(out, .Call(aggregate, as.double(x), op, as.integer(na.rm), dims, PACKAGE='raster')) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { xx <- brick(x, values=FALSE) if (!expand) { xx <- brick(x, values=FALSE) nrow(xx) <- (nrow(x) %/% yfact) * yfact } tr <- blockSize(xx, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) tr$nrows[tr$n] <- nrow(xx) - tr$row[tr$n] + 1 tr$outrows <- ceiling(tr$nrows/yfact) pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact)) out <- writeStart(out, filename=filename, ...) if (inherits(out, 'RasterBrick')) { for (i in 1:tr$n) { dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i])) vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) vals <- .Call(aggregate, as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster') out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i])) vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) vals <- .Call(aggregate, as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster') out <- writeValues(out, vals, tr$write[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } # else not implemented in C if (nl < 2) { if (class(fun) == 'character') { rowcalc <- TRUE fun <- .getColFun(fun) } else { rowcalc <- FALSE } if ( canProcessInMemory(x)) { if (expand) { m <- ceiling(nrx / yfact) } else { m <- floor(nrx / yfact) } vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m) vend <- 0 vvstart <- 1 if (expand) { vals <- getValues(x) yf <- nrx %% yfact } else { vals <- getValuesBlock(x, 1, lastrow, 1, lastcol) yf <- 0 } for (j in 1:m) { if (j == m & yf > 0) { vstart <- vend + 1 vend <- vend + (lastcol * yf) mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE ) temp <- matrix(nrow=yf*xfact, ncol=csteps) temp[1:length(mv)] <- mv cols <- 1:(csteps) + (m-1) * csteps vv[1:nrow(temp), cols] <- temp } else { vstart <- vend + 1 vend <- vend + (lastcol * yfact) mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE ) vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv) vvstart <- vvstart + ncout*nrow(vv) } } if (rowcalc) { vals <- fun(vv, na.rm=na.rm ) } else { vals <- apply(vv, 2, fun, na.rm=na.rm ) } out <- setValues(out, as.vector(vals)) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(x, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) dif <- sum(tr$nrows) - nrow(x) if (dif > 0) { if (expand) { tr$nrows[tr$n] <- tr$nrows[tr$n] - dif } else { dif <- dif %/% xfact if (dif > 0) { tr$nrows[tr$n] <- dif * xfact } else { tr$n <- tr$n - 1 } } } pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) m <- tr$nrows[1] / yfact vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m) w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) for (i in 1:(tr$n-1)) { vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) vend <- 0 vvstart <- 1 for (j in 1:m) { vstart <- vend + 1 vend <- vend + (lastcol * yfact) mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE ) vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv) vvstart <- vvstart + ncout*nrow(vv) } if (rowcalc) { vals <- fun(vv, na.rm=na.rm ) } else { vals <- apply(vv, 2, fun, na.rm=na.rm ) } out <- writeValues(out, vals, tr$write[i]) pbStep(pb, i) } # if (i==tr$n) { i <- tr$n vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol) m <- ceiling(tr$nrows[i] / yfact) vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m) vend <- 0 vvstart <- 1 yf <- tr$nrows[i] %% yfact for (j in 1:m) { if (j == m & yf > 0) { vstart <- vend + 1 vend <- vend + (lastcol * yf) mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE ) temp <- matrix(nrow=yf*xfact, ncol=csteps) temp[1:length(mv)] <- mv cols <- 1:(csteps) + (m-1) * csteps vv[1:nrow(temp), cols] <- temp } else { vstart <- vend + 1 vend <- vend + (lastcol * yfact) mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE ) vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv) vvstart <- vvstart + ncout*nrow(vv) } } if (rowcalc) { vals <- fun(vv, na.rm=na.rm ) } else { vals <- apply(vv, 2, fun, na.rm=na.rm ) } pbStep(pb, i) out <- writeValues(out, vals, tr$write[i]) pbClose(pb) x <- readStop(x) out <- writeStop(out) return(out) } } else { # nlayers > 1 if (canProcessInMemory(x, nlayers(x)+2)) { if (class(fun) == 'character') { op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1) } if (!is.na(op) & doC) { dim <- c(dim(x), dim(out)[1:2], xfact, yfact) v <- .Call(aggregate, as.double(getValues(x)), op, as.integer(na.rm), as.integer(dim), PACKAGE='raster') out <- setValues(out, matrix(v, ncol=dim[3])) return(out) } xx <- raster(x) x <- getValues(x) cols <- rep(rep(1:csteps, each=xfact)[1:ncol(xx)], times=nrow(xx)) rows <- rep(1:rsteps, each=ncol(xx) * yfact)[1:ncell(xx)] cells <- cellFromRowCol(xx, rows, cols) x <- as.matrix( aggregate(x, list(cells), fun, na.rm=na.rm ))[,-1] rm(cells) x <- setValues(out, x) if (filename != ) { x <- writeRaster(x, filename=filename, ...) } return(x) } else { cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact) rows <- rep(1, each=(ncol(x) * yfact)) out <- writeStart(out, filename=filename, ...) x <- readStart(x, ...) cells <- cellFromRowCol(x, rows, cols) nrows <- yfact w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) pb <- pbCreate(rsteps, label='aggregate', ...) for (r in 1:rsteps) { startrow <- 1 + (r - 1) * yfact if ( r==rsteps) { endrow <- min(nrow(x), startrow + yfact - 1) nrows <- endrow - startrow + 1 theserows <- (startrow * rows)[1:(ncol(x)*nrows)] cols <- cols[1:(ncol(x)*nrows)] cells <- cellFromRowCol(x, theserows, cols) } vals <- getValues(x, startrow, nrows) vals <- as.matrix( aggregate(vals, list(cells), fun, na.rm=na.rm ))[,-1] out <- writeValues(out, vals, r) pbStep(pb, r) } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } } ) #library(raster) #r <- raster(nc=9, nr=9) #r <- raster() #r[] = 1:ncell(r) #.aggtest(r, 5, 'min', doC=T)
9 aggregate_sp.R
# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod('aggregate', signature(x='SpatialPolygons'), function(x, vars=NULL, sums=NULL, dissolve=TRUE, ...) { if (dissolve) { stopifnot(require(rgeos)) } if (! .hasSlot(x, 'data') ) { hd <- FALSE if (!is.null(vars)) { if (length(vars) == length(x@polygons)) { x <- SpatialPolygonsDataFrame(x, data=data.frame(ID=vars)) vars <- 1 } } } else { hd <- TRUE } if (isTRUE(is.null(vars))) { if (dissolve) { if (version_GEOS() < 3.3.0) { x <- gUnionCascaded(x) } else { x <- rgeos::gUnaryUnion(x) } } else { p <- list() for (i in 1:length(x)) { nsubobs <- length(x@polygons[[i]]@Polygons) p <- c(p, lapply(1:nsubobs, function(j) x@polygons[[i]]@Polygons[[j]])) } x <- SpatialPolygons(list(Polygons(p, '1')), proj4string=x@proj4string) } #if (hd) { # x <- SpatialPolygonsDataFrame(x, data=data.frame(ID=1)) #} return(x) } else { getVars <- function(v, cn) { vl <- length(v) v <- unique(v) if (is.numeric(v)) { v <- round(v) v <- v[v>0 & v <= ncol(x@data)] if (length(v) < 1) { stop('invalid column numbers') } } else if (is.character(v)) { v <- v[v %in% cn] if (length(v) < 1) { stop('invalid column names') } } v } dat <- x@data cn <- colnames(dat) v <- getVars(vars, cn) dat <- dat[,v, drop=FALSE] crs <- x@proj4string dc <- apply(dat, 1, function(y) paste(as.character(y), collapse='_')) dc <- data.frame(oid=1:length(dc), v=as.integer(as.factor(dc))) id <- dc[!duplicated(dc$v), ,drop=FALSE] id <- id[order(id$v), ] dat <- dat[id[,1], ,drop=FALSE] if (!is.null(sums)) { out <- list() for (i in 1:length(sums)) { if (length(sums[[i]]) != 2) { stop('argument s most of be list in which each element is a list of two (fun + varnames)') } fun = sums[[i]][[1]] if (!is.function(fun)) { if (is.character(fun)) { if (tolower(fun[1]) == 'first') { fun <- function(x) x[1] } else if (tolower(fun[1]) == 'last') { fun <- function(x) x[length(x)] } } } v <- getVars(sums[[i]][[2]], cn) ag <- aggregate(x@data[,v,drop=FALSE], by=list(dc$v), FUN=fun) out[[i]] <- ag[,-1,drop=FALSE] } out <- do.call(cbind, out) dat <- cbind(dat, out) } if (hd) { x <- as(x, 'SpatialPolygons') } if (dissolve) { if (version_GEOS0() < 3.3.0) { x <- lapply(1:nrow(id), function(y) spChFIDs(gUnionCascaded(x[dc[dc$v==y,1],]), as.character(y))) } else { x <- lapply(1:nrow(id), function(y) spChFIDs(rgeos::gUnaryUnion(x[dc[dc$v==y,1],]), as.character(y))) } } else { x <- lapply(1:nrow(id), function(y) spChFIDs(aggregate(x[dc[dc$v==y,1],], dissolve=FALSE), as.character(y))) } x <- do.call(rbind, x) x@proj4string <- crs rownames(dat) <- NULL SpatialPolygonsDataFrame(x, dat, FALSE) } } )
10 alignExtent.R
# Author: Robert J. Hijmans # contact: r.hijmans@gmail.com # Date : November 2010 # Version 1.0 # Licence GPL v3 alignExtent <- function(extent, object, snap='near') { snap <- tolower(snap) stopifnot(snap %in% c('near', 'in', 'out')) extent <- extent(extent) if (!inherits(object, 'BasicRaster')) { stop('object should inherit from BasicRaster') } res <- res(object) orig <- origin(object) # snap points to pixel boundaries if (snap == 'near') { xmn <- round((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- round((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- round((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- round((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } else if (snap == 'out') { xmn <- floor((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- ceiling((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- floor((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- ceiling((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } else if (snap == 'in') { xmn <- ceiling((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- floor((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- ceiling((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- floor((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } if (xmn == xmx) { if (xmn < extent@xmin) { xmx <- xmx + res[1] } else { xmn <- xmn - res[1] } } if (ymn == ymx) { if (ymn < extent@ymin) { ymx <- ymx + res[2] } else { ymn <- ymn - res[2] } } extent(xmn, xmx, ymn, ymx) } .Old.alignExtent <- function(extent, object) { object <- raster(object) oldext <- extent(object) e <- extent(extent) e@xmin <- min(e@xmin, oldext@xmin) e@xmax <- max(e@xmax, oldext@xmax) e@ymin <- min(e@ymin, oldext@ymin) e@ymax <- max(e@ymax, oldext@ymax) col <- colFromX(object, e@xmin) mn <- xFromCol(object, col) - 0.5 * xres(object) mx <- xFromCol(object, col) + 0.5 * xres(object) if (abs(e@xmin - mn) > abs(e@xmin - mx)) { e@xmin <- mx } else { e@xmin <- mn } col <- colFromX(object, e@xmax) if (is.na(col)) mn <- xFromCol(object, col) - 0.5 * xres(object) mx <- xFromCol(object, col) + 0.5 * xres(object) if (abs(e@xmax - mn) > abs(e@xmax - mx)) { e@xmax <- mx } else { e@xmax <- mn } row <- rowFromY(object, e@ymin) mn <- yFromRow(object, row) - 0.5 * yres(object) mx <- yFromRow(object, row) + 0.5 * yres(object) if (abs(e@ymin - mn) > abs(e@ymin - mx)) { e@ymin <- mx } else { e@ymin <- mn } row <- rowFromY(object, e@ymax) mn <- yFromRow(object, row) - 0.5 * yres(object) mx <- yFromRow(object, row) + 0.5 * yres(object) if (abs(e@ymax - mn) > abs(e@ymax - mx)) { e@ymax <- mx } else { e@ymax <- mn } if ( e@ymin == e@ymax ) { if (oldext@ymax > e@ymax) { e@ymax = e@ymax + yres(object) } if (oldext@ymin < e@ymin) { e@ymin = e@ymin - yres(object) } } if ( e@xmin == e@xmax ) { if (oldext@xmax > e@xmax) { e@xmax = e@xmax + xres(object) } if (oldext@xmin < e@xmin) { e@xmin = e@xmin - xres(object) } } return(e) }
11 animate.R
if (!isGeneric(animate)) { setGeneric(animate, function(x, ...) standardGeneric(animate)) } setMethod('animate', signature(x='RasterStackBrick'), function(x, pause=0.25, main, zlim, maxpixels=50000, n=10, ...) { nl <- nlayers(x) if (missing(main)) { main <- getZ(x) if (is.null(main)) { main <- names(x) } } x <- sampleRegular(x, size=maxpixels, asRaster=TRUE, useGDAL=TRUE) if (missing(zlim)) { zlim <- c(min(minValue(x)), max(maxValue(x))) } i <- 1 reps <- 0 while (reps < n) { plot(x[[i]], main = main[i], zlim=zlim, maxpixels=Inf, ...) dev.flush() Sys.sleep(pause) i <- i + 1 if (i > nl) { i <- 1 reps <- reps+1 } } } ) #anim(st, tvals)
12 approxNA.R
# Author: Robert J. Hijmans # Date : February 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric(approxNA)) { setGeneric(approxNA, function(x, ...) standardGeneric(approxNA)) } setMethod('approxNA', signature(x='RasterStackBrick'), function(x, filename=, method=linear, yleft, yright, rule=1, f=0, ties=mean, z=NULL, NArule=1, ...) { filename <- trim(filename) out <- brick(x, values=FALSE) nl <- nlayers(out) if (nl < 2) { warning('cannot interpolate with a single layer') return(x) } if (is.null(z)) { xout <- getZ(x) if (is.null(xout)) { xout <- 1:nl } else if (length(xout)!= nl) { stop('length of values returned by getZ(x) does not match the number of layers of x') } } else { if (length(z)!= nl) { stop('length of z does not match the number of layers of x') } xout <- z } ifelse((missing(yleft) & missing(yright)), ylr <- 0L, ifelse(missing(yleft), ylr <- 1L, ifelse(missing(yright), ylr <- 2L, ylr <- 3L))) if (canProcessInMemory(x)) { x <- getValues(x) s <- rowSums(is.na(x)) if (isTRUE(NArule)) { j <- s == (nl-1) # one non-NA only if (length(j) > 0 ) { x[j, ] <- apply(x[j, ], 1, max, na.rm=TRUE) } } i <- s < (nl-1) # at least two if (length(i) > 0 ) { if (ylr==0) { x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y )) } else if (ylr==1) { x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y )) } else if (ylr==2) { x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y )) } else { x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y )) } } else { warning('no NA values to approximate') } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename=filename, ...) } return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n, label='approxNA', ...) out <- writeStart(out, filename=filename, ...) for (j in 1:tr$n) { v <- getValues(x, row=tr$row[j], nrows=tr$nrows[j]) s <- rowSums(is.na(v)) if (isTRUE(NArule)) { j <- s == (nl-1) # one non-NA only if (length(j) > 0 ) { v[j, ] <- apply(v[j, ], 1, max, na.rm=TRUE) } } i <- (s < nl-1) # need at least two if (length(i) > 0 ) { if (ylr==0) { v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y ) ) } else if (ylr==1) { v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y ) ) } else if (ylr==2) { v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y ) ) } else { v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y ) ) } } out <- writeValues(out, v, tr$row[j]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } )
13 area.R
# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 .cellArea <- function(x, r=6378137) { # currently not used dlonR2 <- xres(x) * (pi / 180) * r^2 lat <- yFromRow(x, 1:nrow(x)) lat <- cbind(lat, lat) dlat <- yres(x) lat[,1] <- lat[,1] + 0.5 * dlat lat[,2] <- lat[,2] - 0.5 * dlat lat <- sin(lat * (pi / 180) ) # for one column: abs(lat[,2] - lat[,1]) * dlonR2 } if (!isGeneric(area)) { setGeneric(area, function(x, ...) standardGeneric(area)) } setMethod('area', signature(x='SpatialPolygons'), function(x, ...) { if (couldBeLonLat(x)) { warning('polygon area in square degrees is not very meaningful') } sapply(x@polygons, function(i) slot(i, 'area')) } ) setMethod('area', signature(x='RasterLayer'), function(x, filename='', na.rm=FALSE, weights=FALSE, ...) { out <- raster(x) if (na.rm) { if (! hasValues(x) ) { na.rm <- FALSE warning('x' has no values, ignoring 'na.rm=TRUE') rm(x) } } else { rm(x) } if (! couldBeLonLat(out)) { warning('This function is only useful for Raster* objects with a longitude/latitude coordinates') ar <- prod(res(out)) return( init(out, function(x) ar, filename=filename, ...) ) } filename <- trim(filename) if (!canProcessInMemory(out, 3) & filename == '') { filename <- rasterTmpFile() } if (filename == '') { v <- matrix(NA, ncol=nrow(out), nrow=ncol(out)) } else { if (weights) { outfname = filename filename = rasterTmpFile() } out <- writeStart(out, filename=filename, ...) } dy <- pointDistance(c(0,0),c(0, yres(out) ), lonlat=TRUE) y <- yFromRow(out, 1:nrow(out)) #dx <- pointDistance(cbind(0, y), cbind(xres(out), y), lonlat=TRUE) dx <- .haversine(0, y, xres(out), y) tr <- blockSize(out) pb <- pbCreate(tr$n, label='area', ...) for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) if (na.rm) { a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA } if (filename == ) { v[,r] <- vv } else { out <- writeValues(out, vv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (filename == ) { v <- as.vector(v) if (weights) { v <- v / sum(v, na.rm=TRUE) } values(out) <- v } else { out <- writeStop(out) if (weights) { total <- cellStats(out, 'sum') out <- calc(out, fun=function(x){x/total}, filename=outfname, ...) } } return(out) } ) setMethod('area', signature(x='RasterStackBrick'), function(x, filename='', na.rm=FALSE, weights=FALSE, ...) { if (! na.rm) { return( area(raster(x), filename=filename, na.rm=FALSE, weights=weights, ...) ) } out <- brick(x, values=FALSE) if (! couldBeLonLat(out)) { stop('This function is only useful for Raster* objects with a longitude/latitude coordinates') } filename <- trim(filename) if (!canProcessInMemory(out) & filename == '') { filename <- rasterTmpFile() } nl <- nlayers(out) if (filename == '') { v <- matrix(NA, ncol=nl, nrow=ncell(out)) } else { if (weights) { outfname = filename filename = rasterTmpFile() } out <- writeStart(out, filename=filename, ...) } dy <- pointDistance(c(0,0),c(0, yres(out) ), lonlat=TRUE) y <- yFromRow(out, 1:nrow(out)) dx <- pointDistance(cbind(0, y), cbind(xres(out), y), lonlat=TRUE) if (.doCluster() ) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nrow(out), length(cl)) cat( 'Using cluster with', nodes, 'nodes\n' ) flush.console() tr <- blockSize(out, minblocks=nodes) pb <- pbCreate(tr$n, label='area', ...) # clFun <- function(i, tr, dx, dy, out, nl) { clFun <- function(i) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) vv <- matrix(rep(vv, times=nl), ncol=nl) a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA return(vv) } snow::clusterExport(cl, c('tr', 'dx', 'dy', 'out', 'nl'), envir=environment()) for (i in 1:nodes) { snow::sendCall(cl[[i]], clFun, list(i), tag=i) } for (i in 1:tr$n) { d <- snow::recvOneData(cl) if (! d$value$success ) { print(d) stop('cluster error') } if (filename == ) { r <- tr$row[d$value$tag]:(tr$row[d$value$tag]+tr$nrows[d$value$tag]-1) start <- (r[1]-1) * ncol(out) + 1 end <- r[length(r)] * ncol(out) v[start:end, ] <- d$value$value } else { out <- writeValues(out, d$value$value, tr$row[d$value$tag]) } if ((nodes + i) <= tr$n) { # snow::sendCall(cl[[d$node]], clFun, list(nodes+i, tr, dx, dy, out, nl), tag=nodes+i) snow::sendCall(cl[[d$node]], clFun, list(nodes+i), tag=nodes+i) } pbStep(pb, i) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='area', ...) #rows <- 1 for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) vv <- matrix(rep(vv, times=nl), ncol=nl) a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA if (filename == ) { start <- (r[1]-1) * ncol(out) + 1 end <- r[length(r)] * ncol(out) v[start:end, ] <- vv } else { out <- writeValues(out, vv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) } if (filename == ) { if (weights) { total <- colSums(v, na.rm=TRUE) v <- t( t(v) / total ) } values(out) <- v } else { out <- writeStop(out) if (weights) { total <- cellStats(out, 'sum') out <- calc(out, fun=function(x){x / total}, filename=outfname, ...) } } return(out) } )
14 arith_sp.R
# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod(+, signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ union(e1, e2) } ) setMethod(*, signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ intersect(e1, e2) } ) setMethod(-, signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ erase(e1, e2) } ) #setMethod(^, signature(e1='SpatialPolygons', e2='SpatialPolygons'), # function(e1, e2){ # crop(e1, e2) # } #)
15 artith.R
# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setMethod(Arith, signature(e1='Raster', e2='Raster'), function(e1, e2){ if (!hasValues(e1)) { stop('first Raster object has no values') } if (!hasValues(e2)) { stop('second Raster object has no values') } nl1 <- nlayers(e1) nl2 <- nlayers(e2) nl <- max(nl1, nl2) proj1 <- projection(e1) proj2 <- projection(e2) if ( ! compareRaster(e1, e2, crs=FALSE, stopiffalse=FALSE) ) { if ( compareRaster(e1, e2, extent=FALSE, rowcol=FALSE, crs=TRUE, res=TRUE, orig=TRUE, stopiffalse=TRUE) ) { ie <- intersect(extent(e1), extent(e2)) if (is.null(ie)) { stop() } warning('Raster objects have different extents. Result for their intersection is returned') e1 <- crop(e1, ie) e2 <- crop(e2, ie) } else { stop() # stops anyway because compareRaster returned FALSE } } if (nl > 1) { r <- brick(e1, values=FALSE, nl=nl) } else { r <- raster(e1) } if (canProcessInMemory(r, 4)) { if (nl1 == nl2 ) { return( setValues(r, values=callGeneric( getValues(e1), getValues(e2))) ) } else { return( setValues(r, matrix(callGeneric( as.vector(getValues(e1)), as.vector(getValues(e2))), ncol=nl)) ) } } else { tr <- blockSize(e1) pb <- pbCreate(tr$n, label='arith') e1 <- readStart(e1) e2 <- readStart(e2) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) if (nl1 == nl2 ) { for (i in 1:tr$n) { v1 <- getValues(e1, row=tr$row[i], nrows=tr$nrows[i]) v2 <- getValues(e2, row=tr$row[i], nrows=tr$nrows[i]) v <- callGeneric( v1, v2 ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v1 <- as.vector(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])) v2 <- as.vector(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) v <- matrix(callGeneric( v1, v2 ), ncol=nl) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e1 <- readStop(e1) e2 <- readStop(e2) pbClose(pb) return(r) } } ) setMethod(Arith, signature(e1='RasterLayer', e2='numeric'), function(e1, e2){ if (!hasValues(e1)) { stop('RasterLayer has no values') } r <- raster(e1) names(r) <- names(e1) if (canProcessInMemory(e1, 4)) { if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } return ( setValues(r, callGeneric(as.numeric(getValues(e1)), e2) ) ) } else { tr <- blockSize(e1) pb <- pbCreate(tr$n, label='arith') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) e1 <- readStart(e1) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2 ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e1 <- readStop(e1) pbClose(pb) return(r) } } ) setMethod(Arith, signature(e1='numeric', e2='RasterLayer'), function(e1, e2){ stopifnot(hasValues(e2)) r <- raster(e2) names(r) <- names(e2) if (canProcessInMemory(e2, 4)) { if (length(e1) > ncell(r)) { e1 <- e1[1:ncell(r)] } return ( setValues(r, callGeneric(e1, getValues(e2)) ) ) } else { tr <- blockSize(e2) pb <- pbCreate(tr$n, label='arith') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) e2 <- readStart(e2) if (length(e1) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e1) v <- callGeneric(e, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e2 <- readStop(e2) pbClose(pb) return(r) } } ) setMethod(Arith, signature(e1='RasterLayerSparse', e2='numeric'), function(e1, e2){ if (!hasValues(e1)) { stop('RasterLayerSparse has no values') } stopifnot(length(e2) == 1) setValues(e1, callGeneric(as.numeric(e1@data@values), e2)) } ) setMethod(Arith, signature(e1='numeric', e2='RasterLayerSparse'), function(e1, e2){ if (!hasValues(e2)) { stop('RasterLayerSparse has no values') } stopifnot(length(e1) == 1) setValues(e2, callGeneric(as.numeric(e2@data@values), e1) ) } ) setMethod(Arith, signature(e1='RasterLayer', e2='logical'), function(e1, e2){ e2 <- as.integer(e2) callGeneric(e1, e2) } ) setMethod(Arith, signature(e1='logical', e2='RasterLayer'), function(e1, e2){ e1 <- as.integer(e1) callGeneric(e1, e2) } ) setMethod(Arith, signature(e1='RasterStackBrick', e2='numeric'), function(e1, e2) { if (length(e2) > 1) { nl <- nlayers(e1) if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } b <- brick(e1, values=FALSE) names(b) <- names(e1) if (canProcessInMemory(e1, 3)) { return( setValues(b, t(callGeneric( t(getValues(e1)), e2))) ) } tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile(), bandorder='BIL') e1 <- readStart(e1) for (i in 1:tr$n) { v <- t (callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2) ) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e1 <- readStop(e1) pbClose(pb) return(b) } # else: b <- brick(e1, values=FALSE) names(b) <- names(e1) if (canProcessInMemory(e1, 3)) { return ( setValues(b, callGeneric(getValues(e1), e2) ) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile()) e1 <- readStart(e1) for (i in 1:tr$n) { v <- callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e1 <- readStop(e1) pbClose(pb) return(b) } } ) setMethod(Arith, signature(e1='numeric', e2='RasterStackBrick'), function(e1, e2) { if (length(e1) > 1) { nl <- nlayers(e2) if (length(e1) != nl) { a <- rep(NA, nl) a[] <- e1 e1 <- a } b <- brick(e2, values=FALSE) names(b) <- names(e2) if (canProcessInMemory(e2, 3)) { return( setValues(b, t(callGeneric( e1, t(getValues(e2))))) ) } tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') e2 <- readStart(e2) b <- writeStart(b, filename=rasterTmpFile()) for (i in 1:tr$n) { v <- t (callGeneric( e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))) ) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e2 <- readStop(e2) pbClose(pb) return(b) } # else: b <- brick(e2, values=FALSE) names(b) <- names(e2) if (canProcessInMemory(e2, 3)) { return ( setValues(b, callGeneric(e1, getValues(e2)) ) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile()) e2 <- readStart(e2) for (i in 1:tr$n) { v <- callGeneric( e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e2 <- readStop(e2) pbClose(pb) return(b) } } ) setMethod(Arith, signature(e1='RasterStackBrick', e2='logical'), # for Arith with NA function(e1, e2){ e2 <- as.integer(e2) callGeneric(e1, e2) } ) setMethod(Arith, signature(e1='logical', e2='RasterStackBrick'), function(e1, e2){ e1 <- as.integer(e1) callGeneric(e1, e2) } ) setMethod(Arith, signature(e1='Extent', e2='numeric'), function(e1, e2){ if (length(e2) == 1) { x1 = e2 x2 = e2 } else if (length(e2) == 2) { x1 = e2[1] x2 = e2[2] } else if (length(e2) == 4) { return(extent(callGeneric(as.vector(e1), e2))) } else { stop('On an Extent object, you can only use Arith with a single number or with two numbers') } r <- e1@xmax - e1@xmin d <- callGeneric(r, x1) d <- (d - r) / 2 e1@xmax <- e1@xmax + d e1@xmin <- e1@xmin - d r <- e1@ymax - e1@ymin d <- callGeneric(r, x2) d <- (d - r) / 2 e1@ymax <- e1@ymax + d e1@ymin <- e1@ymin - d return(e1) } ) setMethod(Arith, signature(e1='numeric', e2='Extent'), function(e1, e2){ callGeneric(e2,e1) } )
16 as.array.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : November 2010 # Version 1.0 # Licence GPL v3 setMethod('as.array', signature(x='RasterLayer'), function(x, maxpixels, ...) { if (!hasValues(x)) { stop('x' has no values) } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } x <- array(as.matrix(x), c(dim(x))) x } ) setMethod('as.array', signature(x='RasterStackBrick'), function(x, maxpixels, transpose=FALSE) { if (!hasValues(x)) { stop('x' has no values) } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } dm <- dim(x) x <- getValues(x) if (transpose) { ar <- array(NA, c(dm[2], dm[1], dm[3])) for (i in 1:dm[3]) { ar[,,i] <- matrix(x[,i], nrow=dm[2], byrow=FALSE) } } else { ar <- array(NA, dm) for (i in 1:dm[3]) { ar[,,i] <- matrix(x[,i], nrow=dm[1], byrow=TRUE) } } ar } )
17 as.data.frame.R
# Author: Robert J. Hijmans # Date : July 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric(as.data.frame)) { setGeneric(as.data.frame, function(x, row.names = NULL, optional = FALSE, ...) standardGeneric(as.data.frame)) } .insertColsInDF <- function(x, y, col, combinenames=TRUE) { cnames <- NULL if (combinenames) { if (ncol(y) > 1) { cnames <- paste(colnames(x)[col], '_', colnames(y), sep='') } } if (ncol(y) == 1) { x[, col] <- y return(x) } else if (col==1) { z <- cbind(y, x[, -1, drop=FALSE]) } else if (col==ncol(x)) { z <- cbind(x[, -ncol(x), drop=FALSE], y) } else { z <- cbind(x[,1:(col-1), drop=FALSE], y, x[,(col+1):ncol(x), drop=FALSE]) } if (!is.null(cnames)) { colnames(z)[col:(col+ncol(y)-1)] <- cnames } z } setMethod('as.data.frame', signature(x='Raster'), function(x, row.names = NULL, optional = FALSE, xy=FALSE, na.rm=FALSE, ...) { if (!canProcessInMemory(x, 4) & na.rm) { r <- raster(x) ncx <- ncol(r) tr <- blockSize(x) pb <- pbCreate(tr$n, label='as.data.frame', ...) x <- readStart(x) v <- NULL for (i in 1:tr$n) { start <- (tr$row[i]-1) * ncx + 1 end <- start + tr$nrows[i] * ncx - 1 vv <- cbind(start:end, getValues(x, row=tr$row[i], nrows=tr$nrows[i])) if (xy) { XY <- data.frame(xyFromCell(r, start:end)) vv <- na.omit(vv, XY) } v <- rbind(v, vv) pbStep(pb, i) } x <- readStop(x) } else { v <- getValues(x) if (xy) { XY <- data.frame(xyFromCell(x, 1:ncell(x))) v <- cbind(XY, v) } if (na.rm) { v <- na.omit(cbind(1:ncell(x), v)) } } v <- as.data.frame(v, row.names=row.names, optional=optional, ...) if (na.rm) { rownames(v) <- as.character(v[,1]) v <- v[,-1,drop=FALSE] } if (nlayers(x) == 1) { colnames(v)[ncol(v)] <- names(x) # for nlayers = 1 } i <- is.factor(x) if (any(is.factor(x))) { if (ncol(v) == 1) { v <- data.frame( factorValues(x, v[,1], 1)) # j <- which(sapply(v, is.character)) # if (length(j) > 0) { # for (jj in j) { # v[, jj] <- as.factor(v[,jj]) # } # } } else { nl <- nlayers(x) if (ncol(v) > nl) { rnge1 <- 1:(ncol(v)-nl) rnge2 <- (ncol(v)-nl+1):ncol(v) v <- cbind(v[, rnge1], .insertFacts(x, v[, rnge2], 1:nl)) } else { v <- .insertFacts(x, v, 1:nl) } } } v } ) setMethod('as.data.frame', signature(x='SpatialPolygons'), function(x, row.names=NULL, optional=FALSE, xy=FALSE, centroids=TRUE, sepNA=FALSE, ...) { if (!xy) { if (.hasSlot(x, 'data')) { return( x@data ) } else { return(NULL) } } if (centroids) { xy <- coordinates(x) xy <- cbind(1:nrow(xy), xy) colnames(xy) <- c('object', 'x', 'y') xy <- as.data.frame(xy, row.names=row.names, optional=optional, ...) if (.hasSlot(x, 'data')) { return( cbind(xy, x@data ) ) } else { return(xy) } } nobs <- length(x@polygons) objlist <- list() cnt <- 0 if (sepNA) { sep <- rep(NA,5) for (i in 1:nobs) { nsubobs <- length(x@polygons[[i]]@Polygons) ps <- lapply(1:nsubobs, function(j) rbind(cbind(j, j+cnt, x@polygons[[i]]@Polygons[[j]]@hole, x@polygons[[i]]@Polygons[[j]]@coords), sep) ) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobs } } else { for (i in 1:nobs) { nsubobs <- length(x@polygons[[i]]@Polygons) ps <- lapply(1:nsubobs, function(j) cbind(j, j+cnt, x@polygons[[i]]@Polygons[[j]]@hole, x@polygons[[i]]@Polygons[[j]]@coords) ) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobs } } obs <- do.call(rbind, objlist) colnames(obs) <- c('object', 'part', 'cump', 'hole', 'x', 'y') rownames(obs) <- NULL obs <- as.data.frame(obs, row.names=row.names, optional=optional, ...) if (.hasSlot(x, 'data')) { d <- x@data d <- data.frame(object=1:nrow(x), x@data) obs <- merge(obs, d, by=1) } if (sepNA) { obs[is.na(obs[,2]), ] <- NA } return( obs ) } ) setMethod('as.data.frame', signature(x='SpatialLines'), function(x, row.names=NULL, optional=FALSE, xy=FALSE, sepNA=FALSE, ...) { if (!xy) { if (.hasSlot(x, 'data')) { return( x@data ) } else { return(NULL) } } nobj <- length(x@lines) objlist <- list() cnt <- 0 if (sepNA) { sep <- rep(NA, 4) for (i in 1:nobs) { nsubobj <- length(x@lines[[i]]@Lines) ps <- lapply(1:nsubobj, function(j) rbind(cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords), sep) ) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobj } } else { for (i in 1:nobj) { nsubobj <- length(x@lines[[i]]@Lines) ps <- lapply(1:nsubobj, function(j) cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords)) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobj } } obs <- do.call(rbind, objlist) colnames(obs) <- c('object', 'part', 'cump', 'x', 'y') rownames(obs) <- NULL obs <- as.data.frame(obs, row.names=row.names, optional=optional, ...) if (.hasSlot(x, 'data')) { d <- x@data d <- data.frame(object=1:nrow(x), x@data) obs <- merge(obs, d, by=1) } if (sepNA) { obs[is.na(obs[,2]), ] <- NA } return (obs) } ) setMethod('as.data.frame', signature(x='SpatialPoints'), function(x, row.names=NULL, optional=FALSE, xy=TRUE, ...) { if (!xy) { if (.hasSlot(x, 'data')) { return( x@data ) } else { return(NULL) } } nobj <- length(x) d <- coordinates(x) if (.hasSlot(x, 'data')) { d <- cbind(d, x@data) } colnames(d)[1:2] <- c('x', 'y') rownames(d) <- NULL as.data.frame(d, row.names=row.names, optional=optional, ...) } ) #setMethod('as.data.frame', signature(x='SpatialPoints'), # function(x, row.names=NULL, optional=FALSE, xy=TRUE, ...) { # # if (!xy) { # if (.hasSlot(x, 'data')) { # return( x@data ) # } else { # return(NULL) # } # } else { # xy <- coordinates(x) # xy <- cbind(1:nrow(xy), xy) # colnames(xy) <- c('object', 'x', 'y') # xy <- as.data.frame(xy, row.names=row.names, optional=optional, ...) # if (.hasSlot(x, 'data')) { # xy <- data.frame(xy, x@data ) # } # return(xy) # } # } #)
18 as.logical.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date: November 2009 # Version 0.9 # Licence GPL v3 setMethod('as.logical', signature(x='Raster'), function(x, filename='', ...) { if (nlayers(x) > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } if (canProcessInMemory(x, 2)){ x <- getValues(x) x[] <- as.logical(x) out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, datatype='INT2S', ...) } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(x) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { v <- as.logical ( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) ) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) return(out) } } )
19 as.matrix.R
# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('as.matrix', signature(x='RasterLayer'), function(x, maxpixels, ...) { if (!hasValues(x)) { stop('x' has no values) } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } return( getValues(x, format='matrix') ) }) setMethod('as.matrix', signature(x='RasterStackBrick'), function(x, maxpixels, ...){ if (!hasValues(x)) { stop('x' has no values) } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } return( getValues(x) ) }) setMethod('as.matrix', signature(x='Extent'), function(x, ...) { b <- bbox(x) rownames(b) <- c('x', 'y') b }) setMethod('as.vector', signature(x='Extent'), function(x, mode = any) { as.vector(c(x@xmin, x@xmax, x@ymin, x@ymax), mode=mode) }) setMethod('as.vector', signature(x='Raster'), function(x, mode = any) { as.vector(getValues(x), mode=mode) })
20 as.raster.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : July 2011 # Version 0.9 # Licence GPL v3 # Note: these functions create a _r_aster object (small r) (grDevices) for use with the rasterImage function # _NOT_ a Raster* object as defined in this package if (!isGeneric(as.raster)) { setGeneric(as.raster, function(x, ...) standardGeneric(as.raster)) } setMethod('as.raster', signature(x='RasterLayer'), function(x, maxpixels=50000, col=rev(terrain.colors(255)), ...) { x <- as.matrix(sampleRegular(x, maxpixels, asRaster=TRUE)) r <- range(x, na.rm=TRUE) x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) x[] <- col[x] as.raster(x) } ) #e <- as.vector(t(bbox(extent(r)))) #a <- as.raster(r) #plot(e[1:2], e[3:4], type = n, xlab=, ylab=) #rasterImage(a, e[1], e[3], e[2], e[4])
21 as.spatial.R
setAs('data.frame', 'SpatialPolygons', function(from) { obs <- unique(from$object) sp <- list() for (i in 1:length(obs)) { s <- from[from$object==obs[i], ] p <- unique(s$part) pp <- list() for (j in 1:length(p)) { ss <- s[s$part==p[j], ] pol <- Polygon(as.matrix(ss)[,5:6]) if (ss$hole[1]) { pol@hole <- TRUE } pp[[j]] <- pol } sp[[i]] <- Polygons(pp, as.character(i)) } SpatialPolygons(sp) } ) setAs('data.frame', 'SpatialPolygonsDataFrame', function(from) { x <- as(from, 'SpatialPolygons') if (ncol(from) > 6) { d <- unique(from[, -c(2:6), drop=FALSE]) rownames(d) <- d$object d <- d[, -1, drop=FALSE] SpatialPolygonsDataFrame(x, d) } else { x } } ) setAs('data.frame', 'SpatialLines', function(from) { obs <- unique(from$object) sp <- list() for (i in 1:length(obs)) { s <- from[from$object==obs[i], ] p <- unique(s$part) pp <- list() for (j in 1:length(p)) { ss <- s[s$part==p[j], ] ln <- Line(as.matrix(ss)[,c('x', 'y')]) pp[[j]] <- ln } sp[[i]] <- Lines(pp, as.character(i)) } SpatialLines(sp) } ) setAs('data.frame', 'SpatialLinesDataFrame', function(from) { x <- as(from, 'SpatialLines') if (ncol(from) > 5) { d <- unique(from[, -c(2:5), drop=FALSE]) rownames(d) <- d$object d <- d[, -1, drop=FALSE] SpatialLinesDataFrame(x, d) } else { x } } )
22 atan2.R
# Author: Robert J. Hijmans # Date : March 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric(atan2)) { setGeneric(atan2, function(y, x) standardGeneric(atan2)) } setMethod(atan2, signature(y='RasterLayer', x='RasterLayer'), function(y, x) { r <- raster(x) compareRaster(r, y) if (canProcessInMemory(r, 3)) { r <- setValues(r, atan2(getValues(y), getValues(x))) } else { tr <- blockSize(x) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile()) for (i in 1:tr$n) { v <- atan2(getValues(y, row=tr$row[i], nrows=tr$nrows[i]), getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } )
23 bands.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(bandnr)) { setGeneric(bandnr, function(x, ...) standardGeneric(bandnr)) } setMethod('bandnr', signature(x='RasterLayer'), function(x) { return(x@data@band) } ) nbands <- function(x) { cx = class(x) if (inherits(x, RasterLayer) | inherits(x, RasterBrick)) { return(x@file@nbands) } else { stop(paste(not implemented for, class(x), objects)) } } .bandOrder <- function(x) { if (inherits(x, RasterStack)) { stop(paste(not implemented for RasterStack objects)) } else { return(paste(x@file@bandorder)) } }
24 barplot.R
# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric(barplot)) { setGeneric(barplot, function(height,...) standardGeneric(barplot)) } setMethod('barplot', 'RasterLayer', function(height, maxpixels=1000000, digits=0, breaks=NULL, col=rainbow, ...) { x <- sampleRegular(height, maxpixels) adj <- length(x) / ncell(height) if (adj < 1) { warning('a sample of ', round(100*adj, 1), '% of the raster cells were used to estimate frequencies') } if (!is.null(digits)) { x <- round(x, digits) } if (!is.null(breaks)) { x <- cut(x, breaks) } x <- table(x) / adj if (is.function(col)) { col <- col(length(x)) } barplot(x, col=col, ...) } )
25 bbox.R
# R function for the raster package # Author: Robert J. Hijmans # contact: r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod('bbox', signature(obj='Extent'), function(obj) { bb <- matrix(ncol=2, nrow=2) colnames(bb) <- c(min,max) rownames(bb) <- c(s1,s2) bb[1,1] <- obj@xmin bb[1,2] <- obj@xmax bb[2,1] <- obj@ymin bb[2,2] <- obj@ymax return(bb) } ) setMethod('bbox', signature(obj='Raster'), function(obj) { obj <- extent(obj) return( bbox(obj) ) } )
26 bilinearValue.R
# Author: Robert J. Hijmans # Date : March 2009 # Licence GPL v3 # updated November 2011 # version 1.0 .bilinearValue <- function(raster, xyCoords, layer, n) { bilinear_old <- function(x, y, x1, x2, y1, y2, v) { v <- v / ((x2-x1)*(y2-y1)) return( v[,1]*(x2-x)*(y2-y) + v[,3]*(x-x1)*(y2-y) + v[,2]*(x2-x)*(y-y1) + v[,4]*(x-x1)*(y-y1) ) #div <- (x2-x1)*(y2-y1) #return ( (v[,1]/div)*(x2-x)*(y2-y) + (v[,3]/div)*(x-x1)*(y2-y) + (v[,2]/div)*(x2-x)*(y-y1) + (v[,4]/div)*(x-x1)*(y-y1) ) } bilinear <- function(xy, x, y, v) { v <- v / ((x[2,]-x[1,])*(y[2,]-y[1,])) return( v[,1]*(x[2,]-xy[,1])*(y[2,]-xy[,2]) + v[,3]*(xy[,1]-x[1,])*(y[2,]-xy[,2]) + v[,2]*(x[2,]-xy[,1])*(xy[,2]-y[1,]) + v[,4]*(xy[,1]-x[1,])*(xy[,2]-y[1,]) ) } r <- raster(raster) nls <- nlayers(raster) four <- fourCellsFromXY(r, xyCoords, duplicates=FALSE) xy4 <- matrix(xyFromCell(r, as.vector(four)), ncol=8) x <- apply(xy4[,1:4,drop=FALSE], 1, range) y <- apply(xy4[,5:8,drop=FALSE], 1, range) xy4 <- cbind(c(x[1,], x[1,], x[2,], x[2,]), c(y[1,], y[2,], y[1,], y[2,])) cells <- cellFromXY(r, xy4) w <- getOption('warn') options('warn'=-1) row1 <- rowFromCell(r, min(cells, na.rm=TRUE)) options('warn' = w) if (is.na(row1)) { if (nls == 1) { return(rep(NA, nrow(xyCoords))) } else { return(matrix(NA, nrow= nrow(xyCoords), ncol=nls)) } } nrows <- rowFromCell(r, max(cells, na.rm=TRUE)) - row1 + 1 offs <- cellFromRowCol(r, row1, 1) - 1 cells <- cells - offs if (nls == 1) { vv <- getValues(raster, row1, nrows) v <- matrix( vv[cells], ncol=4) res <- rep(NA, nrow(v)) rs <- rowSums(is.na(v)) i <- rs==3 if (sum(i) > 0) { cells <- cellFromXY(raster, xyCoords[i,]) - offs res[i] <- vv[cells] } i <- rs > 0 & rs < 3 if (sum(i) > 0) { vv <- v[i,,drop=FALSE] vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2] vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1] vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4] vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3] vmean <- rep(rowMeans(vv, na.rm=TRUE), 4) vv[is.na(vv)] <- vmean[is.na(vv)] # res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], vv) res[i] <- bilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv) } i <- rs==0 if (sum(i) > 0) { # res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], v[i,]) res[i] <- bilinear(xyCoords[i, ,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE]) } res } else { if (missing(layer)) { layer <- 1 } if (missing(n)) { n <- (nls-layer+1) } lyrs <- layer:(layer+n-1) allres <- matrix(ncol=length(lyrs), nrow=nrow(xyCoords)) colnames(allres) <- names(raster)[lyrs] cvv <- getValues(raster, row1, nrows)[, lyrs] cv <- cvv[cells,] for (j in 1:ncol(cv)) { v <- matrix(cv[, j], ncol=4) res <- rep(NA, nrow(v)) rs <- rowSums(is.na(v)) i <- rs==3 if (sum(i) > 0) { cells <- cellFromXY(raster, xyCoords[i,]) - offs res[i] <- cvv[cells, j] } i <- rs > 0 & rs < 3 if (sum(i) > 0) { vv <- v[i,,drop=FALSE] vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2] vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1] vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4] vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3] vmean <- rep(rowMeans(vv, na.rm=TRUE), 4) vv[is.na(vv)] <- vmean[is.na(vv)] res[i] <- bilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv) } i <- rs==0 if (sum(i) > 0) { res[i] <- bilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE]) } allres[,j] <- res } allres } }
27 bind.R
# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 .uniqueNames <- function(x, sep='.') { y <- as.matrix(table(x)) y <- y[y[,1] > 1, ,drop=F] if (nrow(y) > 0) { y <- rownames(y) for (i in 1:length(y)) { j <- which(x==y[i]) x[j] <- paste(x[j], sep, 1:length(j), sep='') } } x } if (!isGeneric(bind)) { setGeneric(bind, function(x, y, ...) standardGeneric(bind)) } setMethod('bind', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ..., keepnames=FALSE) { x <- list(x, y, ...) #p <- sapply(x, proj4string) #if (!isTRUE(all(p==p[1]))) { } haswarned <- FALSE projx <- proj4string(x[[1]]) for (i in 2:length(x)) { if (is.na(proj4string(x[[i]]))) { x[[i]]@proj4string <- x[[1]]@proj4string } else if (! identical(projx, proj4string(x[[i]])) ) { if (!haswarned) { warning('non identical CRS') haswarned <- TRUE } x[[i]]@proj4string <- x[[1]]@proj4string } } rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialPolygons')) { return( do.call( rbind, x)) } if (all(cls == 'SpatialPolygonsDataFrame')) { dat <- lapply( x, function(x) { slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialPolygons')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) return( SpatialPolygonsDataFrame(x, dat) ) } dat <- NULL # dataFound <- FALSE for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { # dataFound <- TRUE if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:length(x[[i]]@polygons),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat) + length(x[[i]])),] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialPolygons')) x <- do.call(rbind, x) SpatialPolygonsDataFrame(x, dat) } ) setMethod('bind', signature(x='SpatialLines', y='SpatialLines'), function(x, y, ..., keepnames=FALSE) { x <- list(x, y, ...) haswarned <- FALSE projx <- proj4string(x[[1]]) for (i in 2:length(x)) { if (is.na(proj4string(x[[i]]))) { x[[i]]@proj4string <- x[[1]]@proj4string } else if (! identical(projx, proj4string(x[[i]])) ) { if (!haswarned) { warning('non identical CRS') haswarned <- TRUE } x[[i]]@proj4string <- x[[1]]@proj4string } } rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialLines')) { return( do.call( rbind, x)) } if (all(cls == 'SpatialLinesDataFrame')) { dat <- lapply( x, function(x) { slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialLines')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) return( SpatialLinesDataFrame(x, dat) ) } dat <- NULL # dataFound <- FALSE for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { # dataFound <- TRUE if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:length(x[[i]]@lines),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat)+nrow(x[[i]]@coords)),] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialLines')) x <- do.call(rbind, x) SpatialLinesDataFrame(x, dat) } ) setMethod('bind', signature(x='SpatialPoints', y='SpatialPoints'), function(x, y, ..., keepnames=FALSE) { x <- list(x, y, ...) rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialPoints')) { return( do.call( rbind, x)) } if (all(cls == 'SpatialPointsDataFrame')) { dat <- lapply( x, function(x) { slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialPoints')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) return( SpatialPointsDataFrame(x, dat) ) } dat <- NULL for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:nrow(x[[i]]@coords),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat)+nrow(x[[i]]@coords)),] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialPoints')) x <- do.call(rbind, x) SpatialPoinsDataFrame(x, dat) } )
28 blend.R
# Authors: Rafael Wueest, WSL Birmensdorf, Switzerland, rafael.wueest@wsl.ch, # Etienne B. Racine, Robert J. Hijmans # Date : November 2012 # Version 1.0 # Licence GPL v3 # needs to be generalized to n input rasters and to multi-layer objects .old_blend <- function(r1, r2) { i <- intersect(raster(r1), raster(r2)) j <- extend(i, c(1,1)) a <- crop(r1, j) b <- crop(r2, j) values(a) <- 1 values(b) <- 2 ab <- merge(a, b) ba <- merge(b, a) p1 <- rasterToPoints(ab, function(x) x==2) p2 <- rasterToPoints(ba, function(x) x==1) d1 <- distanceFromPoints(i, p1[,1:2]) d2 <- distanceFromPoints(i, p2[,1:2]) dsum <- d1 + d2 z1 <- d1 * crop(r1, d1) / dsum z2 <- d2 * crop(r2, d2) / dsum merge(z1 + z2, r1, r2) } .blend <- function(x, y, logistic=FALSE, filename='', ...) { # check for difference in extent stopifnot( extent(x) != extent(y)) # define logistic function if (logistic) { G <- 1 f <- 0.001 k <- log(G/f-1)/(0.5*G) logfun <- function(x) { G /(1+exp(-k*G*x)*(G/f-1)) } } # create intersection rasters i <- intersect(raster(x), raster(y)) j <- extend(i, c(1,1)) # is one of the rasters nested within the other? ex <- extent(x) ey <- extent(y) exy <- union(ex, ey) if (exy==ex | exy==ey){ # the nested case # which raster has the smaller extent? if (extent(x) < extent(y)){ rlarge <- y rsmall <- x } else { rlarge <- x rsmall <- y } # create points around nested raster a <- crop(rlarge, j) a <- setValues(a, 1) b <- crop(rsmall, j) b <- setValues(b, 2) ba <- merge(b, a) p <- rasterToPoints(ba, function(x) x==1) # calculate distances to points in nested raster d <- distanceFromPoints(i, p[,1:2]) # standardize these distances dmin <- cellStats(d,'min') d.sc <- (d - dmin + 1e-9) / (cellStats(d,'max') - dmin) # the logistic case if(logistic){ d.sc<-logfun(d.sc) } # create distance weighted rasters z1 <- d.sc * crop(rsmall, d.sc) z2 <- abs(1-d.sc) * crop(rlarge, d.sc) # merge rasters m <- merge(z1 + z2, rsmall, rlarge, filename=filename, ...) } else { # the overlapping case # create points around ovelapping area a <- crop(x, j) a <- setValues(a, 1) b <- crop(y, j) b <- setValues(b, 2) ab <- merge(a, b) ba <- merge(b, a) p1 <- rasterToPoints(ab, function(x) x==2) p2 <- rasterToPoints(ba, function(x) x==1) # calculate distances to points in overlapping area d1 <- distanceFromPoints(i, p1[,1:2]) d2 <- distanceFromPoints(i, p2[,1:2]) # the logistic case if(logistic){ d1min <- cellStats(d1,'min') d2min <- cellStats(d2,'min') d1 <- logfun((d1 - d1min + 1e-9)/(cellStats(d1,'max') - d1min)) d2 <- logfun((d2 - d2min + 1e-9)/(cellStats(d2,'max') - d2min)) } # sum distance rasters dsum <- d1 + d2 # create distance weighted rasters z1 <- d1 * crop(x, d1) / dsum z2 <- d2 * crop(y, d2) / dsum z <- sum(z1, z2) # merge rasters m <- merge(z, x, y, filename=filename, ...) } m }
29 blockSize.R
# Author: Robert J. Hijmans # Date : November 2009 # Version 0.9 # Licence GPL v3 blockSize <- function(x, chunksize, n=nlayers(x), minblocks=4, minrows=1) { n <- max(n, 1) if (missing(chunksize)) { bs <- .chunksize() / n } else { bs <- chunksize } blockrows <- try(slot(x@file, 'blockrows'), silent=TRUE) if (class(blockrows) == 'try-error') { blockrows <- 1 } blockrows <- max(blockrows, 1) nr <- nrow(x) size <- min(nr, max(1, floor(bs / ncol(x)))) # min number of chunks if (size > 1) { minblocks <- min(nr, max(1, minblocks)) size <- min(ceiling(nr/minblocks), size) } size <- min(max(size, minrows), nr) size <- max(minrows, blockrows * round(size / blockrows)) nb <- ceiling(nr / size) row <- (0:(nb-1))*size + 1 nrows <- rep(size, length(row)) dif = nb * size - nr nrows[length(nrows)] = nrows[length(nrows)] - dif return(list(row=row, nrows=nrows, n=nb)) }
30 boundaries.R
# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 # name overlap with igraph edge <- function(x, ...) { warning('edge is obsolete and will be removed from this package. Use the boundaries function instead') boundaries(x, ...) warning('edge is obsolete and will be removed from this package. Use the boundaries function instead') } if (!isGeneric(boundaries)) { setGeneric(boundaries, function(x, ...) standardGeneric(boundaries)) } setMethod('boundaries', signature(x='RasterLayer'), function(x, type='inner', classes=FALSE, directions=8, asNA=FALSE, filename=, ...) { stopifnot( nlayers(x) == 1 ) stopifnot( hasValues(x) ) filename <- trim(filename) out <- raster(x) gll <- as.integer( .isGlobalLonLat(out) ) type <- tolower(type) if (! type %in% c('inner', 'outer')) { stop(type must be 'inner', or 'outer') } if (type=='inner') { type <- as.integer(0) } else { type <- as.integer(1) } classes <- as.integer(as.logical(classes)) directions <- as.integer(directions) stopifnot(directions %in% c(4,8)) # asZero <- as.integer(as.logical(asZero)) datatype <- list(...)$datatype if (is.null(datatype)) { datatype <- 'INT2S' } if (canProcessInMemory(out, 4)) { x <- as.matrix(x) if (gll) { x <- cbind(x[, ncol(x)], x, x[, 1]) } else { x <- cbind(x[, 1], x, x[, ncol(x)]) } x <- rbind(x[1,], x, x[nrow(x),]) paddim <- as.integer(dim(x)) x <- .Call('edge', as.integer(t(x)), paddim, classes, type, directions, NAOK=TRUE, PACKAGE='raster') if (asNA) { x[x==0] <- as.integer(NA) } x <- matrix(x, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) x <- x[2:(nrow(x)-1), 2:(ncol(x)-1)] x <- setValues(out, as.vector(t(x))) if (filename != '') { x <- writeRaster(x, filename, datatype=datatype, ...) } return(x) } else { out <- writeStart(out, filename, datatype=datatype, ...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label='boundaries', ...) nc <- ncol(out)+2 v <- getValues(x, row=1, nrows=tr$nrows[1]+1) v <- matrix(v, ncol=tr$nrows[1]+1) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- as.integer(cbind(v[,1], v)) v <- .Call('edge', v, as.integer(c(tr$nrows[1]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster') if (asNA) { v[v==0] <- as.integer(NA) } v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, 1) pbStep(pb, 1) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+2) v <- matrix(v, ncol=tr$nrows[1]+2) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- .Call('edge', as.integer(v), as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster') v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } i <- tr$n v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+1) v <- matrix(v, ncol=tr$nrows[i]+1) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- as.integer(cbind(v, v[,ncol(v)])) v <- .Call('edge', v, as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster') v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, tr$row[i]) pbStep(pb, tr$n) out <- writeStop(out) pbClose(pb) } return(out) } )
31 boxplot.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : November 2010 # Version 1.0 # Licence GPL v3 if (!isGeneric(boxplot)) { setGeneric(boxplot, function(x, ...) standardGeneric(boxplot)) } setMethod('boxplot', signature(x='RasterStackBrick'), function(x, maxpixels=100000, ...) { nl <- nlayers(x) cn <- names(x) if ( canProcessInMemory(x)) { x <- getValues(x) } else { warning('taking a sample of ', maxpixels, ' cells') x = sampleRegular(x, maxpixels, useGDAL=TRUE) } colnames(x) <- cn boxplot(x, ...) } ) setMethod('boxplot', signature(x='RasterLayer'), function(x, y=NULL, maxpixels=100000, ...) { if (is.null(y)) { cn <- names(x) if ( canProcessInMemory(x)) { x <- getValues(x) } else { warning('taking a sample of ', maxpixels, ' cells') x = sampleRegular(x, maxpixels, useGDAL=TRUE) } x <- matrix(x) colnames(x) <- cn boxplot(x, ...) } else { s <- stack(x,y) if ( canProcessInMemory(x)) { s <- getValues(s) } else { warning('taking a sample of ', maxpixels, ' cells') s <- sampleRegular(s, maxpixels, useGDAL=TRUE) } cn <- colnames(s) f <- as.formula(paste(cn[1], '~', cn[2])) boxplot(f, data=x, ...) } } )
32 brick.R
# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(brick)) { setGeneric(brick, function(x, ...) standardGeneric(brick)) } setMethod('brick', signature(x='missing'), function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, nl=1, crs) { e <- extent(xmn, xmx, ymn, ymx) if (missing(crs)) { if (e@xmin > -400 & e@xmax < 400 & e@ymin > -90.1 & e@ymax < 90.1) { crs =+proj=longlat +datum=WGS84 } else { crs=NA } } b <- brick(e, nrows=nrows, ncols=ncols, crs=crs, nl=nl) return(b) } ) setMethod('brick', signature(x='character'), function(x, ...) { .rasterObjectFromFile(x, objecttype='RasterBrick', ...) } ) setMethod('brick', signature(x='RasterLayer'), function(x, ..., values=TRUE, nl=1, filename='') { nl <- max(round(nl), 0) if (!hasValues(x)) { values <- FALSE } if (!values) { b <- brick(x@extent, nrows=nrow(x), ncols=ncol(x), crs=projection(x), nl=nl) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } return(b) } filename <- trim(filename) dots <- list(...) if (is.null(dots$format)) { format <- .filetype(filename=filename) } if (is.null(dots$datatype)) { datatype <- .datatype() } if (is.null(dots$overwrite)) { overwrite <- .overwrite() } if (is.null(dots$progress)) { progress <- .progress() } x <- stack(x, ...) brick(x, values=values, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress) } ) setMethod('brick', signature(x='RasterStack'), function(x, values=TRUE, nl, filename='', ...){ e <- x@extent b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=projection(x)) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } if (missing(nl)) { nl <- nlayers(x) if (nl < 1) { values <- FALSE } } else { nl <- max(round(nl), 0) values <- FALSE } b@data@nlayers <- as.integer(nl) filename <- trim(filename) if (values) { b@data@names <- names(x)[1:nl] if (canProcessInMemory(b, nl*2)) { b <- setValues( b, getValues(x)[,1:nl]) if (any(is.factor(x))) { b@data@isfactor <- is.factor(x) b@data@attributes <- levels(x) } if (filename != '') { b <- writeRaster(b, filename, ...) } return(b) } else { b <- writeStart(b, filename=filename, ...) tr <- blockSize(b) pb <- pbCreate(tr$n, ...) x <- readStart(x) for (i in 1:tr$n) { vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) b <- writeValues(b, vv, tr$row[i]) pbStep(pb, i) } pbClose(pb) b <- writeStop(b) x <- readStop(x) return(b) } } else { b@data@min <- rep(Inf, b@data@nlayers) b@data@max <- rep(-Inf, b@data@nlayers) return(b) } } ) setMethod('brick', signature(x='RasterBrick'), function(x, nl, ...){ if (missing(nl)) { nl <- nlayers(x) } e <- x@extent b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=projection(x)) b@data@nlayers <- as.integer(nl) b@data@min <- rep(Inf, nl) b@data@max <- rep(-Inf, nl) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } return(b) } ) setMethod('brick', signature(x='Extent'), function(x, nrows=10, ncols=10, crs=NA, nl=1) { bb <- extent(x) nr = as.integer(round(nrows)) nc = as.integer(round(ncols)) if (nc < 1) { stop(ncols should be > 0) } if (nr < 1) { stop(nrows should be > 0) } b <- new(RasterBrick, extent=bb, ncols=nc, nrows=nr) projection(b) <- crs nl <- max(round(nl), 0) b@data@nlayers <- as.integer(nl) b@data@isfactor <- rep(FALSE, nl) return(b) } ) setMethod('brick', signature(x='SpatialGrid'), function(x){ b <- brick() extent(b) <- extent(x) projection(b) <- x@proj4string dim(b) <- c(x@grid@cells.dim[2], x@grid@cells.dim[1]) if (class(x) == 'SpatialGridDataFrame') { x <- x@data b@data@isfactor <- rep(FALSE, ncol(x)) isfact <- sapply(x, function(i) is.factor(i) | is.character(i)) b@data@isfactor <- isfact if (any(isfact)) { for (i in which(isfact)) { rat <- data.frame(table(x[[i]])) rat <- data.frame(1:nrow(rat), rat[,2], rat[,1]) colnames(rat) <- c(ID, COUNT, colnames(x)[i]) b@data@attributes[[i]] <- rat x[,i] <- as.integer(x[,i]) } } b <- setValues(b, as.matrix(x)) b@data@names <- colnames(x) } return(b) } ) setMethod('brick', signature(x='SpatialPixels'), function(x) { if (inherits( x, 'SpatialPixelsDataFrame')) { x <- as(x, 'SpatialGridDataFrame') } else { x <- as(x, 'SpatialGrid') } return(brick(x)) } ) setMethod('brick', signature(x='array'), function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs=NA, transpose=FALSE) { dm <- dim(x) if (is.matrix(x)) { stop('cannot coerce a matrix to a RasterBrick') } if (length(dm) != 3) { stop('array has wrong number of dimensions (needs to be 3)') } b <- brick(xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs, nl=dm[3]) names(b) <- dimnames(x)[[3]] if (transpose) { dim(b) <- c(dm[2], dm[1], dm[3]) } else { dim(b) <- dm # aperm etc suggested by Justin McGrath # https://r-forge.r-project.org/forum/message.php?msg_id=4312 x = aperm(x, perm=c(2,1,3)) } attributes(x) <- list() dim(x) <- c(dm[1] * dm[2], dm[3]) setValues(b, x) } ) setMethod('brick', signature(x='big.matrix'), function(x, template, filename='', ...) { stopifnot(inherits(template, 'BasicRaster')) stopifnot(nrow(x) == ncell(template)) r <- brick(template) filename <- trim(filename) names(r) <- colnames(x) if (canProcessInMemory(r)) { r <- setValues(r, x[]) if (filename != '') { r <- writeRaster(r, filename, ...) } } else { tr <- blockSize(r) pb <- pbCreate(tr$n, ...) r <- writeStart(r, filename, ...) for (i in 1:tr$n) { r <- writeValues(r, x[tr$row[i]:(tr$row[i]+tr$nrows[i]-1), ], tr$row[i] ) pbStep(pb) } r <- writeStop(r) pbClose(pb) } return(r) } ) setMethod('brick', signature(x='kasc'), function(x) { as(x, 'RasterBrick') } ) setMethod('brick', signature(x='grf'), function(x) { as(x, 'RasterBrick') } ) setMethod('brick', signature(x='list'), function(x) { x <- stack(x) brick(x) } )
33 buffer.R
# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric('buffer')) { setGeneric('buffer', function(x, ...) standardGeneric('buffer')) } setMethod('buffer', signature(x='RasterLayer'), function(x, width=0, filename='', doEdge=FALSE, ...) { stopifnot(width > 0) if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (class(pts) == try-error) { return( .distanceRows(x, filename=filename, ...) ) } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells (for which to compute a distance)') } out <- raster(x) filename <- trim(filename) if (couldBeLonLat(x)) { longlat=TRUE } else { longlat=FALSE } if (canProcessInMemory(out, 6)) { pb <- pbCreate(4, label='buffer', ...) x <- values(x) i <- which(is.na(x)) if (length(i) < 1) { stop('raster has no NA values to compute distance to') } pbStep(pb) x[] <- 0 xy <- xyFromCell(out, i) x[i] <- .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster') pbStep(pb) x[x > width] <- NA x[!is.na(x)] <- 1 pbStep(pb) out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } pbStep(pb) pbClose(pb) return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='buffer', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- 0 if (length(j) > 0) { vals[j] <- .Call(distanceToNearestPoint, xy[j,,drop=FALSE], pts, as.integer(longlat), PACKAGE='raster') } vals[vals > width] <- NA vals[!is.na(vals)] <- 1 out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } )
34 calc.R
# Author: Robert J. Hijmans & Matteo Mattiuzzi # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(calc)) { setGeneric(calc, function(x, fun, ...) standardGeneric(calc)) } .makeTextFun <- function(fun) { if (class(fun) != 'character') { if (is.primitive(fun)) { test <- try(deparse(fun)[[1]], silent=TRUE) if (test == '.Primitive(\sum\)') { fun <- 'sum' } else if (test == '.Primitive(\min\)') { fun <- 'min' } else if (test == '.Primitive(\max\)') { fun <- 'max' } } else { test1 <- isTRUE(try( deparse(fun)[2] == 'UseMethod(\mean\)', silent=TRUE)) test2 <- isTRUE(try( fun@generic == 'mean', silent=TRUE)) if (test1 | test2) { fun <- 'mean' } } } return(fun) } .getRowFun <- function(fun) { if (fun == 'mean') { return(rowMeans) } else if (fun == 'sum') { return(rowSums) } else if (fun == 'min') { return(.rowMin) } else if (fun == 'max') { return(.rowMax) } else { stop('unknown fun') } } .getColFun <- function(fun) { if (fun == 'mean') { return(colMeans) } else if (fun == 'sum') { return(colSums) } else if (fun == 'min') { return(.colMin) } else if (fun == 'max') { return(.colMax) } else { stop('unknown fun') } } .calcTest <- function(tstdat, fun, na.rm, forcefun=FALSE, forceapply=FALSE) { if (forcefun & forceapply) { forcefun <- FALSE forceapply <- FALSE } trans <- FALSE doapply <- FALSE makemat <- FALSE nl <- NCOL(tstdat) if (nl == 1) { # the main difference with nl > 1 is that # it is important to avoid using apply when a normal fun( ) call will do. # that is a MAJOR time saver. But in the case of a RasterStackBrick it is more # natural to try apply first. if (forceapply) { doapply <- TRUE makemat <- TRUE tstdat <- matrix(tstdat, ncol=1) if (missing(na.rm)) { test <- try( apply(tstdat, 1, fun), silent=TRUE) } else { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) } if (length(test) < length(tstdat) | class(test) == 'try-error') { stop('cannot forceapply this function') } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } else { if (! missing(na.rm)) { test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) if (class(test) == 'try-error') { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) doapply <- TRUE if (class(test) == 'try-error') { stop(cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?) } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } } else { test <- try(fun(tstdat), silent=TRUE) if (length(test) < length(tstdat) | class(test) == 'try-error') { doapply <- TRUE makemat <- TRUE tstdat <- matrix(tstdat, ncol=1) test <- try( apply(tstdat, 1, fun), silent=TRUE) if (class(test) == 'try-error') { stop(cannot use this function) } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } } } } else { if (forcefun) { doapply <- FALSE test <- fun(tstdat) } else { doapply <- TRUE if (! missing(na.rm)) { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) if (class(test) == 'try-error') { doapply <- FALSE test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) if (class(test) == 'try-error') { stop(cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?) } } else if (is.matrix(test)) { trans <- TRUE } } else { test <- try( apply(tstdat, 1, fun), silent=TRUE) if (class(test) == 'try-error') { doapply <- FALSE test <- try(fun(tstdat), silent=TRUE) if (class(test) == 'try-error') { stop(cannot use this function) } } else if (is.matrix(test)) { trans <- TRUE } } } } if (trans) { test <- t(test) test <- ncol(test) } else { test <- length(test) / 5 } nlout <- as.integer(test) list(doapply=doapply, makemat=makemat, trans=trans, nlout=nlout) } #.calcTest(test[1:5], fun, forceapply=T) setMethod('calc', signature(x='Raster', fun='function'), function(x, fun, filename='', na.rm, forcefun=FALSE, forceapply=FALSE, ...) { nl <- nlayers(x) test <- .calcTest(x[1:5], fun, na.rm, forcefun, forceapply) doapply <- test$doapply makemat <- test$makemat trans <- test$trans if (test$nlout == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) out@data@nlayers <- test$nlout } fun <- .makeTextFun(fun) if (class(fun) == 'character') { doapply <- FALSE fun <- .getRowFun(fun) } filename <- trim(filename) if (canProcessInMemory(x, max(nlayers(x), nlayers(out)) * 2)) { x <- getValues(x) if (makemat) { x <- matrix(x, ncol=1) } if (missing(na.rm)) { if (! doapply ) { x <- fun(x ) } else { x <- apply(x, 1, fun ) } } else { if ( ! doapply ) { x <- fun(x, na.rm=na.rm ) } else { x <- apply(x, 1, fun, na.rm=na.rm) } } if (trans) { x <- t(x) } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } # else x <- readStart(x) out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='calc', ...) if (missing(na.rm)) { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if ( ! doapply ) { v <- fun(v) } else { if (makemat) { v <- matrix(v, ncol=1) } v <- apply(v, 1, fun) if (trans) { v <- t(v) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if ( ! doapply ) { v <- fun(v, na.rm=na.rm) } else { if (makemat) { v <- matrix(v, ncol=1) } v <- apply(v, 1, fun, na.rm=na.rm) if (trans) { v <- t(v) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb) } } out <- writeStop(out) x <- readStop(x) pbClose(pb) return(out) } )
35 canProcessInMemory.R
# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 canProcessInMemory <- function(x, n=4) { # for testing purposes # rasterOptions(format='GTiff') # require(ncdf) # require(rgdal) # rasterOptions(format='big.matrix') # rasterOptions(format='CDF') # rasterOptions(overwrite=TRUE) # rasterOptions(todisk=TRUE) # return(FALSE) if (.toDisk()) { return(FALSE) } n <- n + nlayers(x) - 1 cells <- round( 1.1 * ncell(x) ) * n if ( cells > .maxmemory() ) { return(FALSE) } else { return(TRUE) } } # if (cells > .maxmemory()) { # return(FALSE) # } else if ( cells < 1000000 ) { # return(TRUE) # } else { # return(TRUE) # } # if (substr( R.Version()$platform, 1, 7) == i386-pc ) { # # windows, function memory.size available # memneed <- cells * 8 * n / (1024 * 1024) # memavail <- 0.5 * (memory.size(NA)-memory.size(FALSE)) # if (memneed > memavail) { # return(FALSE) # } else { # return(TRUE) # } # } else { # g <- gc() # if (.Platform$OS.type == unix){ ## Memory in KB, from: http://stackoverflow.com/questions/2441046/how-to-get-physical-memory-in-bash # mem <- as.numeric(system(grep MemTotal /proc/meminfo | awk '{print $2}',intern=TRUE)) # w <- getOption('warn') # on.exit(options('warn'= w)) # options('warn'=-1) # r <- try( matrix(0.1, ncol=n, nrow=cells), silent=TRUE ) # if (class(r) == try-error) { # return( FALSE ) # g <- gc() # return( TRUE ) # }
36 cellFromLine.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : December 2009 # Version 0.9 # Licence GPL v3 cellFromLine <- function(object, lns) { spbb <- bbox(lns) rsbb <- bbox(object) addres <- 2 * max(res(object)) nlns <- length( lns@lines ) res <- list() res[[nlns+1]] = NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { return(res[1:nlns]) } rr <- raster(object) for (i in 1:nlns) { pp <- lns[i,] spbb <- bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # always TRUE? res[[i]] <- cellFromXY(object, xy) } } } return( res[1:nlns] ) }
37 cellFromPolygon.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : January 2011 # Version 1.0 # Licence GPL v3 cellFromPolygon <- function(object, p, weights=FALSE) { spbb <- bbox(p) rsbb <- bbox(object) addres <- max(res(object)) npol <- length(p@polygons) res <- list() res[[npol+1]] = NA if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { return(res[1:npol]) } rr <- raster(object) for (i in 1:npol) { pp <- p[i,] spbb <- bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE) rc[rc==0] <- NA xy <- rasterToPoints(rc) weight <- xy[,3] / 100 xy <- xy[,-3] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch holes or very small polygons cell <- cellFromXY(object, xy) if (weights) { res[[i]] <- cbind(cell, weight) } else { res[[i]] <- cell } } } } return( res[1:npol] ) }
38 cellRowCol.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 rowFromCell <- function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA trunc((cell-1)/ncol(object)) + 1 } .rowFromCell <- function(object, cell) { trunc((cell-1)/ncol(object)) + 1 } cellFromRow <- function(object, rownr) { object <- raster(object) rownr <- round(rownr) if (length(rownr)==1) { return(cellFromRowCol(object, rownr, 1):cellFromRowCol(object, rownr, object@ncols)) } cols <- rep(1:ncol(object), times=length(rownr)) rows <- rep(rownr, each=ncol(object)) cellFromRowCol(object, rows, cols) } cellFromCol <- function(object, colnr) { object <- raster(object) colnr <- round(colnr) rows <- rep(1:nrow(object), times=length(colnr)) cols <- rep(colnr, each=nrow(object)) return(cellFromRowCol(object, rows, cols)) } .OLD_cellFromRowColCombine <- function(object, rownr, colnr) { object <- raster(object) rc <- expand.grid(rownr, colnr) return( cellFromRowCol(object, rc[,1], rc[,2])) } cellFromRowColCombine <- function(object, rownr, colnr) { object <- raster(object) rownr[rownr < 1 | rownr > object@nrows] <- NA colnr[colnr < 1 | colnr > object@ncols] <- NA cols <- rep(colnr, times=length(rownr)) dim(cols) <- c(length(colnr), length(rownr)) cols <- t(cols) rownr <- (rownr-1) * object@ncols cols <- cols + rownr as.vector(t(cols)) } colFromCell <- function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA rownr <- trunc((cell-1)/object@ncols) + 1 as.integer(cell - ((rownr-1) * object@ncols)) } .colFromCell <- function(object, cell) { nc <- object@ncols rownr <- trunc((cell-1)/nc) + 1 cell - ((rownr-1) * nc) } rowColFromCell <- function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA row <- as.integer(trunc((cell-1)/object@ncols) + 1) col <- as.integer(cell - ((row-1) * object@ncols)) return(cbind(row, col)) } cellFromRowCol <- function(object, rownr, colnr) { object <- raster(object) rownr <- round(rownr) colnr <- round(colnr) rownr[rownr < 1 | rownr > nrow(object)] <- NA colnr[colnr < 1 | colnr > ncol(object)] <- NA # recycle if length(rownr) != length(colnr) x <- cbind(rownr, colnr) as.vector((x[,1]-1) * ncol(object) + x[,2]) }
39 cellsFromExtent.R
# R function for the raster package # Author: Robert J. Hijmans # contact: r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 cellsFromExtent <- function(object, extent, expand=FALSE) { object <- raster(object) extent <- alignExtent(extent(extent), object) innerBox <- intersect(extent(object), extent) if (is.null(innerBox)) { return(NULL) } srow <- rowFromY(object, innerBox@ymax - 0.5 * yres(object)) erow <- rowFromY(object, innerBox@ymin + 0.5 * yres(object)) scol <- colFromX(object, innerBox@xmin + 0.5 * xres(object)) ecol <- colFromX(object, innerBox@xmax - 0.5 * xres(object)) if (expand) { srow <- srow - round((extent@ymax - innerBox@ymax) / yres(object)) erow <- erow + round((innerBox@ymin - extent@ymin) / yres(object)) scol <- scol - round((innerBox@xmin - extent@xmin) / xres(object)) ecol <- ecol + round((extent@xmax - innerBox@xmax) / xres(object)) } return(cellFromRowColCombine(object, srow:erow, scol:ecol)) }
40 cellStats.R
# Author: Robert J. Hijmans # Date : March 2009 / April 2012 # Version 1.0 # Licence GPL v3 .csTextFun <- function(fun) { if (class(fun) != 'character') { if (is.primitive(fun)) { test <- try(deparse(fun)[[1]], silent=TRUE) if (test == '.Primitive(\sum\)') { fun <- 'sum' } else if (test == '.Primitive(\min\)') { fun <- 'min' } else if (test == '.Primitive(\max\)') { fun <- 'max' } } else { f <- paste(deparse(fun), collapse = \n) if (f == paste(deparse(mean), collapse = \n)) { fun <- 'mean' } else if (f == paste(deparse(sd), collapse = \n)) { fun <- 'sd' } else if (f == paste(deparse(range), collapse = \n)) { fun <- 'range' } } } return(fun) } if (!isGeneric(cellStats)) { setGeneric(cellStats, function(x, stat, ...) standardGeneric(cellStats)) } setMethod('cellStats', signature(x='RasterStackBrick'), function(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) { stopifnot(hasValues(x)) makeMat <- FALSE if (nlayers(x) == 1) { makeMat <- TRUE #return( cellStats(raster(x, values=TRUE, stat=stat, ...) ) } stat <- .csTextFun(stat) if (!inMemory(x)) { if (canProcessInMemory(x)) { x <- readAll(x) } } if (inMemory(x) ) { x <- getValues(x) if (makeMat) { x <- matrix(x, ncol=1) } if (class(stat) == 'character') { if (stat == mean ) { return( colMeans(x, na.rm=na.rm) ) } else if (stat == sum ) { return( colSums(x, na.rm=na.rm) ) } else if (stat == min ) { v <- .colMin(x, na.rm=na.rm) names(v) <- names(x) return(v) } else if (stat == max ) { v <- .colMax(x, na.rm=na.rm) names(v) <- names(x) return(v) } else if (stat == 'countNA') { warning ('countNA' is deprecated. Use freq(x, 'value=NA') instead) return( colSums(is.na(x)) ) } else if (stat == 'sd') { st <- apply(x, 2, sd, na.rm=na.rm) if (! asSample) { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } st <- sqrt(st^2 * (n/(n-1))) } return(st) } else if (stat == 'rms') { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } if (asSample) { n <- n-1 } # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n)) return( sqrt( apply(x, 2, function(x) sum(x^2))/n ) ) } else if (stat == 'skew') { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } if (asSample) { sdx <- apply(x, 2, sd, na.rm=na.rm) } else { sdx <- apply(x, 2, function(x) sqrt(sum((x-mean(x, na.rm=na.rm))^2, na.rm=na.rm)/n)) } return( colSums(t(t(x) - colMeans(x, na.rm=na.rm))^3, na.rm=na.rm) / (n * sdx^3) ) } } # else return(apply(x, 2, stat, na.rm=na.rm, ...)) } if (class(stat) != 'character') { stop('cannot use this function for large files') } st <- NULL counts <- FALSE if (stat == 'sum') { fun <- sum st <- 0 } else if (stat == 'min') { st <- Inf } else if (stat == 'max') { st <- -Inf } else if (stat == 'range') { fun <- range } else if (stat == 'countNA') { warning ('countNA' is depracted. Use freq(x, 'value=NA') instead) st <- 0 counts <- TRUE } else if (stat == 'skew') { zmean <- cellStats(x, 'mean') cnt <- 0 d3 <- 0 sumsq <- 0 counts <- TRUE } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') { st <- 0 sumsq <- 0 cnt <- 0 counts <- TRUE } else { stop(invalid 'stat'. Should be 'sum', 'min', 'max', 'sd', 'mean', 'rms', or 'skew') } tr <- blockSize(x) pb <- pbCreate(tr$n, label='cellStats', ...) for (i in 1:tr$n) { d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (makeMat) { d <- matrix(d, ncol=1) } if (counts) { if (na.rm & stat != 'countNA') { nas <- colSums( is.na(d) ) if (min(nas) == nrow(d)) { next } cells <- nrow(d) - nas } else { if (stat == 'countNA') { nas <- colSums( is.na(d) ) } else { cells <- nrow(d) } } } if (stat=='mean') { st <- colSums(d, na.rm=na.rm) + st cnt <- cnt + cells } else if (stat=='sum') { st <- colSums(d, na.rm=na.rm) + st } else if (stat == 'sd') { st <- colSums(d, na.rm=na.rm) + st cnt <- cnt + cells sumsq <- colSums(d^2, na.rm=na.rm) + sumsq } else if (stat=='countNA') { st <- st + nas } else if (stat=='rms') { sumsq <- colSums(d^2, na.rm=TRUE) + sumsq cnt <- cnt + cells } else if (stat=='skew') { d <- t( t(d) - zmean ) sumsq <- colSums(d^2, na.rm=TRUE) + sumsq d3 <- colSums(d^3, na.rm=TRUE) + d3 cnt <- cnt + cells } else if (stat=='min') { tmp <- .colMin(d, na.rm=na.rm) st <- pmin(st, tmp, na.rm=na.rm) } else if (stat=='max') { tmp <- .colMax(d, na.rm=na.rm) st <- pmax(st, tmp, na.rm=na.rm) } else { # range st <- apply(rbind(d, st), 2, fun, na.rm=na.rm) } pbStep(pb, i) } if (stat == 'sd') { meansq <- (st/cnt)^2 st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1))) if (!asSample) { st <- sqrt( st^2 * (cnt / (cnt-1))) } } else if (stat == 'mean') { st <- st / cnt } else if (stat == 'rms') { if (asSample) { st <- sqrt(sumsq/(cnt-1)) } else { st <- sqrt(sumsq/cnt) } } else if (stat == 'skew') { if (asSample) { stsd <- sqrt(sumsq/(cnt-1))^3 } else { stsd <- sqrt(sumsq/cnt)^3 } st <- d3 / (cnt*stsd) } else if (stat %in% c('min', 'max')) { names(st) <- names(x) } pbClose(pb) return(st) } ) setMethod('cellStats', signature(x='RasterLayer'), function(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) { stopifnot(hasValues(x)) stat <- .csTextFun(stat) if (! inMemory(x) ) { if (canProcessInMemory(x)) { x <- readAll(x) } } if (inMemory(x) ) { x <- getValues(x) if (class(stat) == 'character') { if (stat == mean ) { return( mean(x, na.rm=na.rm) ) } else if (stat == sum ) { return( sum(x, na.rm=na.rm) ) } else if (stat == 'countNA') { return( sum(is.na(x)) ) } else if (stat == range ) { return( range(x, na.rm=na.rm) ) } else if (stat == min ) { return( min(x, na.rm=na.rm) ) } else if (stat == max ) { return( max(x, na.rm=na.rm) ) } else if (stat == sd ) { st <- sd(x, na.rm=na.rm) if (! asSample) { if (na.rm) { n <- length(na.omit(x)) } else { n <- length(x) } st <- sqrt(st^2 * (n/(n-1))) } return(st) } else if (stat == 'rms') { if (na.rm) { n <- sum(! is.na(x)) } else { n <- length(x) } if (asSample) { n <- n-1 } # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n)) return( sqrt( sum(x^2)/n ) ) } else if (stat == skew ) { if (na.rm) { x <- na.omit(x) } if (asSample) { sdx <- sd(x) } else { sdx <- sqrt(sum((x-mean(x))^2)/(length(x))) } return( sum( (x - mean(x))^3 ) / (length(x) * sdx^3) ) } } else { return( stat(x, na.rm=na.rm) ) } } if (class(stat) != 'character') { stop('cannot use this function for large files') } st <- NULL counts <- FALSE if (stat == 'sum') { fun <- sum st <- 0 } else if (stat == 'min') { fun <- min } else if (stat == 'max') { fun <- max } else if (stat == 'range') { fun <- range } else if (stat == 'countNA') { st <- 0 counts <- TRUE } else if (stat == 'skew') { zmean <- cellStats(x, 'mean') cnt <- 0 sumsq <- 0 d3 <- 0 counts <- TRUE } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') { st <- 0 sumsq <- 0 cnt <- 0 counts <- TRUE } else { stop(invalid 'stat'. Should be sum, min, max, sd, mean, or 'countNA') } tr <- blockSize(x) pb <- pbCreate(tr$n, label='cellStats', ...) for (i in 1:tr$n) { d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (counts) { if (na.rm & stat != 'countNA') { nas <- sum(is.na(d) ) if (nas == length(d)) { # only NAs next } cells <- length(d) - nas } else { if (stat == 'countNA') { nas <- sum(is.na(d) ) } else { cells <- length(d) } } } if (stat=='mean') { st <- sum(d, na.rm=na.rm) + st cnt <- cnt + cells } else if (stat=='sum') { st <- sum(d, na.rm=na.rm) + st } else if (stat == 'sd') { st <- sum(d, na.rm=na.rm) + st cnt <- cnt + cells sumsq <- sum( d^2 , na.rm=na.rm) + sumsq } else if (stat=='countNA') { st <- st + nas } else if (stat=='skew') { d <- (d - zmean) sumsq <- sum(d^2, na.rm=na.rm) + sumsq d3 <- sum(d^3, na.rm=na.rm) + d3 cnt <- cnt + cells } else if (stat=='rms') { sumsq <- sum( d^2, na.rm=na.rm) + sumsq cnt <- cnt + cells } else { st <- fun(d, st, na.rm=na.rm) } pbStep(pb, i) } pbClose(pb) if (stat == 'sd') { meansq <- (st/cnt)^2 st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1))) if (!asSample) { st <- sqrt( st^2 * (cnt / (cnt-1))) } } else if (stat == 'mean') { st <- st / cnt } else if (stat == 'rms') { if (asSample) { st <- sqrt(sumsq/(cnt-1)) } else { st <- sqrt(sumsq/cnt) } } else if (stat == 'skew') { if (asSample) { stsd <- sqrt(sumsq/(cnt-1))^3 } else { stsd <- sqrt(sumsq/cnt)^3 } st <- d3 / (cnt*stsd) } return(st) } )
41 cellValues.R
# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 .cellValues <- function(x, cells, layer, nl, df=FALSE, factors=FALSE) { if (inherits(x, 'RasterLayer')) { result <- .readCells(x, cells, 1) lyrs <- layer <- 1 } else { nlyrs <- nlayers(x) if (missing(layer)) { layer <- 1 } layer <- min( max( round(layer), 1), nlyrs) if (missing(nl)) { nl <- nlyrs } nl <- min( max( round(nl), 1), nlyrs-layer+1 ) lyrs <- layer:(layer+nl-1) if (inherits(x, 'RasterStack')) { result <- matrix(ncol=nl, nrow=length(cells)) colnames(result) <- names(x)[lyrs] for (i in 1:length(lyrs)) { result[,i] <- .readCells( x@layers[[lyrs[i]]], cells, 1) } } else if (inherits(x, 'RasterBrick')) { if (inMemory(x)) { cells[cells < 1 | cells > ncell(x)] <- NA if (length(na.omit(cells)) == 0) { return(cells) } result <- x@data@values[cells, lyrs, drop=FALSE] } else if (x@file@driver == 'netcdf') { result <- .readBrickCellsNetCDF(x, cells, layer, nl) } else { result <- .readCells(x, cells, lyrs) } if (is.null(dim(result))) { result <- matrix(result, ncol=length(lyrs)) } colnames(result) <- names(x)[lyrs] } } if (df) { if (!is.matrix(result)) { result <- matrix(result) colnames(result) <- names(x) } result <- data.frame(ID=1:NROW(result), result) facts <- is.factor(x)[lyrs] if (any(facts) & factors) { if (ncol(result) == 2) { # possibly multiple columns added result <- cbind(result[,1,drop=FALSE], factorValues(x, result[,2], layer)) } else { # single columns only i <- which(facts) for (j in i) { result <- .insertColsInDF(result, factorValues(x, result[, j+1], j), j+1) } } } } result }
42 clamp.R
# Author: Robert J. Hijmans # Date : July 2013 # Version 1.0 # Licence GPL v3 if (!isGeneric(clamp)) { setGeneric(clamp, function(x, ...) standardGeneric(clamp)) } setMethod('clamp', signature(x='Raster'), function(x, lower=-Inf, upper=Inf, useValues=TRUE, filename='', ...) { if (!hasValues(x)) return(x) range <- as.numeric(c(lower[1], upper[1])) nl <- nlayers(x) if (nl > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } useValues <- as.integer(useValues) if (canProcessInMemory(out)) { out <- setValues(out, .Call('clamp', values(x), range, useValues, NAOK=TRUE, PACKAGE='raster')) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='clamp', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) vals <- .Call('clamp', vals, range, useValues, NAOK=TRUE, PACKAGE='raster') if (nl > 1) { vals <- matrix(vals, ncol=nl) } out <- writeValues(out, vals, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) } return(out) } )
43 clearValues.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 .clearRaster <- function(object) { object@data@inmemory <- FALSE # object@data@indices = vector(mode='numeric') object@data@values <- vector() if ( ! fromDisk(object) ) { object@data@min <- Inf object@data@max <- -Inf object@data@haveminmax <- FALSE } return(object) } clearValues <- function(x) { if (class(x) == BasicRaster ) { return(x) } else if (inherits(x, RasterLayer )) { x <- .clearRaster(x) } else if (inherits(x, RasterStack) ) { for (i in seq(along=nlayers(x))) { if (fromDisk(x@layers[[i]])) { x@layers[[i]] <- .clearRaster(x@layers[[i]]) } } } else if (inherits(x, 'RasterBrick')) { x@data@values <- matrix(NA,0,0) x@data@inmemory <- FALSE # x@data@indices = c(0,0) if ( ! fromDisk(x) ) { x@data@min <- rep(Inf, nlayers(x)) x@data@max <- rep(-Inf, nlayers(x)) x@data@haveminmax <- FALSE } } return(x) } .clearFile <- function(x) { x@file@name <- '' x@data@fromdisk <- FALSE x@file@driver <- return(x) }
44 click.R
# Author: Robert J. Hijmans # Date : January 2009 - December 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric(click)) { setGeneric(click, function(x, ...) standardGeneric(click)) } .getClicks <- function(...) { res <- list() while(TRUE) { loc <- locator(1, ...) if (is.null(loc)) break res <- c(res, loc) } matrix(res, ncol=2, byrow=TRUE) } .getCellFromClick <- function(x, n, type, id, ...) { loc <- locator(n, type, ...) xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=1:n) } cells <- cellFromXY(x, xyCoords) cells <- unique(na.omit(cells)) if (length(cells) == 0 ) { stop('no valid cells selected') } cells } setMethod('click', signature(x='missing'), function(x, n=1, type=n, ...) { loc <- locator(n, type, ...) cbind(x=loc$x, y=loc$y) } ) setMethod('click', signature(x='SpatialGrid'), function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type=n, ...) { r <- raster(x) cells <- .getCellFromClick(r, n, type, id, ...) if (.hasSlot(x, 'data')) { value <- x@data[cells, ,drop=FALSE] } else { value <- NULL } if (cell) { value <- data.frame(cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } ) setMethod('click', signature(x='SpatialPixels'), function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type=n, ...) { r <- raster(x) cells <- .getCellFromClick(r, n, type, id, ...) if (.hasSlot(x, 'data')) { value <- x@data[cells, ,drop=FALSE] } else { value <- NULL } if (cell) { value <- data.frame(cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } ) .oldclick <- function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type=n, ...) { cells <- .getCellFromClick(x, n, type, id, ...) value <- .cellValues(x, cells) if (is.null(dim(value))) { value <- matrix(value) colnames(value) <- names(x) } if (cell) { value <- data.frame(cell=cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } setMethod('click', signature(x='Raster'), function(x, n=Inf, id=FALSE, xy=FALSE, cell=FALSE, type=n, show=TRUE, ...) { values <- NULL i <- 0 n <- max(n, 1) while (i < n) { i <- i + 1 loc <- locator(1, type, ...) xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=i) } cells <- na.omit(cellFromXY(x, xyCoords)) if (length(cells) == 0) break value <- extract(x, cells) if (cell) { value <- data.frame(cell=cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } if (show) { print(value) flush.console() } if (is.null(dim(value))) { value <- matrix(value) colnames(value) <- names(x) } values <- rbind(values, value) } if (show) { invisible(values) } else { values } }) setMethod('click', signature(x='SpatialPolygons'), function(x, n=1, id=FALSE, xy=FALSE, type=n, ...) { loc <- locator(n, type, ...) xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=1:n) } xyCoords <- SpatialPoints(xyCoords) xyCoords@proj4string <- x@proj4string i <- which(!is.na(over(x, xyCoords))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } if (xy) { x <- cbind(xyCoords, x) } return(x) } ) setMethod('click', signature(x='SpatialLines'), function(x, ...) { e <- as(drawExtent(), 'SpatialPolygons') e@proj4string <- x@proj4string i <- which(!is.na(over(x, e))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } x } ) setMethod('click', signature(x='SpatialPoints'), function(x, ...) { e <- as(drawExtent(), 'SpatialPolygons') e@proj4string <- x@proj4string i <- which(!is.na(over(x, e))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } x } )
45 clump.R
# Authors: Robert J. Hijmans and Jacob van Etten, # Date : May 2010 # Version 1.0 # Licence GPL v3 # RH: updated for igraph (from igraph0) # sept 23, 2012 if (!isGeneric(clump)) { setGeneric(clump, function(x, ...) standardGeneric(clump)) } .smallClump <- function(x, directions=8) { x1 <- raster(x) val <- which(getValues(x) != 0) if (length(val) == 0) { return( setValues(x1, NA) ) } adjv <- as.vector(t(adjacent(x1, val, directions=directions, target=val, pairs=TRUE))) # RH. To fix problem of missing single cells, perhaps more efficient than include=T in adjacent add <- val[! val %in% adjv] adjv <- c(adjv, rep(add, each=2)) cl <- igraph::clusters(igraph::graph(adjv, directed=FALSE))$membership[val] cl <- as.numeric(as.factor(cl)) # RH force 1 to n x1[val] <- cl return(x1) } setMethod('clump', signature(x='RasterLayer'), function(x, filename='', directions=8, gaps=TRUE, ...) { if( !require(igraph)) { stop('you need to install the igraph package to be able to use this function') } if (! directions %in% c(4,8)) { stop('directions should be 4 or 8') } filename <- trim(filename) if (filename != & file.exists(filename)) { if (! .overwrite(...)) { stop(file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it) } } datatype <- list(...)$datatype out <- raster(x) if (canProcessInMemory(out, 3)) { x <- .smallClump(x, directions) names(x) <- 'clumps' if (filename != '') { if (is.null(datatype)) { x <- writeRaster(x, filename, datatype='INT4S') } else { x <- writeRaster(x, filename, ...) } } return(x) } # else names(out) <- 'clumps' out <- writeStart(out, filename=rasterTmpFile(), datatype='INT4S') tr <- blockSize(out, minrows=3) pb <- pbCreate(tr$n, label='clump', ...) ext <- c(xmin(out), xmax(out), ymax(out), NA) maxval <- 0 rcl <- matrix(nrow=0, ncol=2) for (i in 1:tr$n) { ext[4] <- yFromRow(out, tr$row[i]) + 0.5 * yres(out) endrow <- tr$row[i] + tr$nrows[i] - 1 ext[3] <- yFromRow(out, endrow) - 1.5 * yres(out) # one additional row for overlap xc <- crop(x, extent(ext)) xc <- .smallClump(xc, directions) + maxval if (i > 1) { firstrow <- getValues(xc, 1) rc <- na.omit(unique(cbind(lastrow, firstrow))) rcl <- rbind(rcl, rc) } lastrow <- getValues(xc, nrow(xc)) mv <- maxValue(xc) if (!is.na(mv)) { maxval <- mv } out <- writeValues(out, getValues(xc, 1, tr$nrows[i]), tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) if (nrow(rcl) > 0) { g <- igraph::graph.edgelist(rcl, directed=FALSE) clumps <- igraph::clusters(g)$membership rc <- cbind(V(g), clumps) i <- rc[,1] != rc[,2] rc <- rc[i, ,drop=FALSE] if (is.null(datatype)) { out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, datatype='INT4S', ...) } else { out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, ...) } return(out) } else if (!gaps) { un <- unique(out) un <- data.frame(cbind(un, clumps=1:length(un))) if (is.null(datatype)) { return( subs(out, un, subsWithNA=FALSE, filename=filename, datatype='INT4S', ...) ) } else { return( subs(out, un, subsWithNA=FALSE, filename=filename, ...) ) } } else if (filename != '') { if (is.null(datatype)) { return( writeRaster(out, filename=filename, datatype='INT4S', ...) ) } else { return( writeRaster(out, filename=filename, ...) ) } } else { return(out) } } )
46 clusterR.R
# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 clusterR <- function(x, fun, args=NULL, export=NULL, filename='', cl=NULL, m=2, ...) { if (is.null(cl)) { cl <- getCluster() on.exit( returnCluster() ) } if (!is.null(export)) { snow::clusterExport(cl, export) } nodes <- length(cl) out <- raster(x) m <- max(1, round(m)) tr <- blockSize(x, minblocks=nodes*m ) if (tr$n < nodes) { nodes <- tr$n } tr$row2 <- tr$row + tr$nrows - 1 pb <- pbCreate(tr$n, label='clusterR', ...) if (!is.null(args)) { stopifnot(is.list(args)) clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) getValues(r) } } for (i in 1:nodes) { snow::sendCall(cl[[i]], clusfun, list(fun, i), tag=i) } if (canProcessInMemory(x)) { for (i in 1:tr$n) { pbStep(pb, i) d <- snow::recvOneData(cl) if (! d$value$success ) { print(d$value$value) stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } res <- matrix(NA, nrow=ncell(out), ncol=nl) } j <- d$value$tag res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value ni <- nodes + i if (ni <= tr$n) { snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } pbClose(pb) return(out) } else { for (i in 1:tr$n) { pbStep(pb, i) d <- snow::recvOneData(cl) if (! d$value$success ) { stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } out <- writeStart(out, filename=filename, ...) } out <- writeValues(out, d$value$value, tr$row[d$value$tag]) ni <- nodes + i if (ni <= tr$n) { snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- writeStop(out) pbClose(pb) return(out) } } .clusterR2 <- function(x, fun, args=NULL, filename='', cl=NULL, m=2, ...) { if (is.null(cl)) { cl <- getCluster() on.exit( returnCluster() ) } nodes <- length(cl) out <- raster(x) m <- max(1, round(m)) tr <- blockSize(x, minblocks=max(nodes+1, nodes*m)) nodes <- min(nodes, tr$n-1) tr$row2 <- tr$row + tr$nrows - 1 pb <- pbCreate(tr$n, label='clusterR', ...) canPiM <- canProcessInMemory(x) if (!is.null(args)) { stopifnot(is.list(args)) if (canPiM) { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) writeValues(out, getValues(r), tr$row[i]) return(i) } } } else { if (canPiM) { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) writeValues(out, getValues(r), tr$row[i]) return(i) } } } if (canPiM) { for (i in 1:nodes) { snow::sendCall(cl[[i]], clusfun, list(fun, i), tag=i) } for (i in 1:tr$n) { pbStep(pb, i) d <- snow::recvOneData(cl) if (! d$value$success ) { stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } res <- matrix(NA, nrow=ncell(out), ncol=nl) } j <- d$value$tag res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value ni <- nodes + i if (ni <= tr$n) { snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } pbClose(pb) return(out) } else { r <- crop(x, extent(out, r1=tr$row[1], r2=tr$row2[1], c1=1, c2=ncol(out))) r <- fun(values(r)) nl <- NCOL(r) if (nl > 1) { out <- brick(out, nl=nl) } out <- writeStart(out, filename=filename, ...) out <- writeValues(out, r, 1) for (i in 1:nodes) { snow::sendCall(cl[[i]], clusfun, list(fun, i+1), tag=i+1) } for (i in 2:tr$n) { pbStep(pb, i) d <- snow::recvOneData(cl) if (! d$value$success ) { stop('cluster error') } ni <- nodes + i if (ni <= tr$n) { snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- writeStop(out) pbClose(pb) return(out) } }
47 coerce.R
# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 # To sp pixel/grid objects setAs('Raster', 'GridTopology', function(from) { rs <- res(from) orig <- bbox(from)[,1] + 0.5 * rs GridTopology(orig, rs, dim(from)[2:1] ) } ) setAs('GridTopology', 'RasterLayer', function(from) { raster(extent(from), nrows=from@cells.dim[2], ncols=from@cells.dim[1]) } ) setAs('Raster', 'SpatialPixels', function(from) { if (rotated(from)) { stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the rectify function') } sp <- rasterToPoints(from, fun=NULL, spatial=FALSE) r <- raster(from) sp <- SpatialPoints(sp[,1:2], proj4string= projection(r, FALSE)) grd <- as(r, 'GridTopology') SpatialPixels(points=sp, grid=grd) } ) setAs('Raster', 'SpatialPixelsDataFrame', function(from) { if (rotated(from)) { stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the rectify function') } v <- rasterToPoints(from, fun=NULL, spatial=FALSE) r <- raster(from) sp <- SpatialPoints(v[,1:2], proj4string= projection(r, FALSE)) grd <- as(r, 'GridTopology') if (ncol(v) > 2) { v <- data.frame(v[, 3:ncol(v), drop = FALSE]) if (any(is.factor(from))) { f <- levels(from) for (i in 1:length(f)) { if (!is.null(f[[i]])) { v[,i] <- as.factor(f[[i]][v[,i]]) } } } SpatialPixelsDataFrame(points=sp, data=v, grid=grd) } else { warning('object has no values, returning a SpatialPixels object') SpatialPixels(points=sp, grid=grd) } } ) setAs('Raster', 'SpatialGrid', function(from) { if (rotated(from)) { stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the rectify function') } r <- raster(from) crs <- projection(r, FALSE) grd <- as(r, 'GridTopology') SpatialGrid(grd, proj4string=crs) } ) setAs('Raster', 'SpatialGridDataFrame', function(from) { if (rotated(from)) { stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the rectify function') } r <- raster(from) crs <- projection(r, FALSE) grd <- as(r, 'GridTopology') if (hasValues(from)) { sp <- SpatialGridDataFrame(grd, proj4string=crs, data=as.data.frame(from)) } else { warning('object has no values, returning a SpatialGrid object') sp <- SpatialGrid(grd, proj4string=crs) } sp } ) # To sp vector objects setAs('Raster', 'SpatialPolygons', function(from){ r <- rasterToPolygons(from[[1]]) as(r, 'SpatialPolygons') } ) setAs('Raster', 'SpatialPolygonsDataFrame', function(from){ return( rasterToPolygons(from) ) } ) setAs('Raster', 'SpatialPoints', function(from) { SpatialPoints(rasterToPoints(from, spatial=FALSE)[,1:2], proj4string=projection(from, FALSE)) } ) setAs('Raster', 'SpatialPointsDataFrame', function(from) { rasterToPoints(from, spatial=TRUE) } ) setAs('Extent', 'SpatialPolygons', function(from){ p <- rbind(c(from@xmin, from@ymin), c(from@xmin, from@ymax), c(from@xmax, from@ymax), c(from@xmax, from@ymin), c(from@xmin, from@ymin) ) SpatialPolygons(list(Polygons(list(Polygon(p)), 1))) } ) setAs('Extent', 'SpatialPoints', function(from){ p <- cbind( x=c( from@xmin, from@xmin, from@xmax, from@xmax), y=c(from@ymin, from@ymax, from@ymin, from@ymax) ) SpatialPoints(p) } ) # to RasterLayer setAs('SpatialGrid', 'RasterLayer', function(from){ return(raster (from)) } ) setAs('SpatialPixels', 'RasterLayer', function(from){ return(raster (from)) } ) setAs('SpatialGrid', 'BasicRaster', function(from){ to <- new('BasicRaster') to@extent <- extent(from) projection(to) <- from@proj4string dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1]) return(to) } ) setAs('SpatialPixels', 'BasicRaster', function(from){ to <- new('BasicRaster') to@extent <- extent(from) projection(to) <- from@proj4string dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1]) return(to) } ) # to RasterStack setAs('SpatialGrid', 'RasterStack', function(from){ stack(from) } ) setAs('SpatialPixels', 'RasterStack', function(from){ stack(from) } ) # to RasterBrick setAs('SpatialGrid', 'RasterBrick', function(from){ return(brick(from)) } ) setAs('SpatialPixels', 'RasterBrick', function(from){ return(brick(from)) } ) setAs('STFDF', 'RasterBrick', function(from) { time <- from@time nc <- ncol(from@data) r <- raster(from@sp) b <- brick(r, nl=length(time) * nc) b <- setZ(b, rep(time, nc)) # rep changes some time formats names(b) <- paste(rep(colnames(from@data), each=length(time)), as.character(time), sep='') # need to improve this for character, factor variables m <- as.numeric(as.matrix(from@data)) setValues(b, m) } ) setAs('STSDF', 'RasterBrick', function(from) { from <- as(from, 'STFDF') as(from, 'RasterBrick') } ) # Between Raster objects setAs('RasterStack', 'RasterLayer', function(from){ return( raster(from)) } ) setAs('RasterBrick', 'RasterLayer', function(from){ return( raster(from)) } ) setAs('RasterLayer', 'RasterStack', function(from){ return( stack(from)) } ) setAs('RasterLayer', 'RasterBrick', function(from){ return( brick(from)) } ) setAs('matrix', 'RasterLayer', function(from){ return(raster(from)) } ) setAs('RasterLayer', 'matrix', function(from){ return( getValues(from, format='matrix')) } ) setAs('RasterLayer', 'RasterLayerSparse', function(from){ x <- new('RasterLayerSparse', from) v <- na.omit(cbind(1:ncell(from), getValues(from))) setValues(x, v[,2], v[,1]) } ) setAs('RasterLayerSparse', 'RasterLayer', function(from){ raster(from) } ) # image .rasterToImage <- function(r) { x <- xFromCol(r,1:ncol(r)) y <- yFromRow(r, nrow(r):1) z <- t(as.matrix(r)[nrow(r):1,]) list(x=x, y=y, z=z) } # spatstat setAs('im', 'RasterLayer', function(from) { r <- raster(nrows=from$dim[1], ncols=from$dim[2], xmn=from$xrange[1], xmx=from$xrange[2], ymn=from$yrange[1], ymx=from$yrange[2], crs='') r <- setValues(r, from$v) flip(r, direction='y') } ) # adehabitat setAs('asc', 'RasterLayer', function(from) { d <- t(from[]) d <- d[nrow(d):1, ] type <- attr(from, type) if (type == 'factor') { warning('factor type converted to numeric') } cz <- attr(from, cellsize) xmn <- attr(from, 'xll') - 0.5 * cz ymn <- attr(from, 'yll') - 0.5 * cz xmx <- xmn + ncol(d) * cz ymx <- ymn + nrow(d) * cz e <- extent(xmn, xmx, ymn, ymx) d <- raster(d) extent(d) = e return(d) } ) setAs('RasterLayer', 'asc', function(from) { asc <- getValues(from, format='matrix') asc <- asc[nrow(asc):1, ] attr(asc, cellsize) <- xres(from) attr(asc, xll) <- xmin(from) + 0.5 * xres(from) attr(asc, yll) <- ymin(from) + 0.5 * yres(from) attr(asc, type) <- 'numeric' class(asc) <- asc return(asc) } ) setAs('kasc', 'RasterBrick', function(from) { names <- colnames(from) cz <- attr(from, cellsize) ncol <- attr(from, 'ncol') nrow <- attr(from, 'nrow') xmn <- attr(from, 'xll') - 0.5 * cz ymn <- attr(from, 'yll') - 0.5 * cz xmx <- xmn + ncol * cz ymx <- ymn + nrow * cz e <- extent(xmn, xmx, ymn, ymx) b <- brick(e, nrow=nrow, ncol=ncol) m = matrix(NA, ncol=ncol(from), nrow=nrow(from)) for (i in 1:ncol(m)) { m[,i] <- as.numeric(from[,i]) } dim(m) <- dim(from) b <- setValues(b, m) names(b) <- names return(b) } ) setAs('kasc', 'RasterStack', function(from) { names <- colnames(from) cz <- attr(from, cellsize) ncol <- attr(from, 'ncol') nrow <- attr(from, 'nrow') xmn <- attr(from, 'xll') - 0.5 * cz ymn <- attr(from, 'yll') - 0.5 * cz xmx <- xmn + ncol * cz ymx <- ymn + nrow * cz e <- extent(xmn, xmx, ymn, ymx) r <- raster(e, nrow=nrow, ncol=ncol) r <- setValues(r, as.numeric(from[,1])) names(r) <- names[1] s <- stack(r) if (ncol(from) > 1) { for (i in 2:ncol(from)) { r <- setValues(r, as.numeric(from[,i])) names(r) <- names[i] s <- addLayer(s, r) } } return(s) } ) # kernel density estimate (kde) from package ks setAs('kde', 'RasterLayer', function(from) { x <- t(from$estimate) x <- x[nrow(x):1,] raster(x, xmn=min(from$eval.points[[1]]), xmx=max(from$eval.points[[1]]), ymn=min(from$eval.points[[2]]), ymx=max(from$eval.points[[2]]) ) } ) setAs('grf', 'RasterBrick', function(from) { x <- from$data if (!is.matrix(x)) { x <- matrix(x) } ncell <- nrow(x) nl <- ncol(x) nc <- nr <- as.integer(sqrt(ncell)) dim(x) <- c(nr, nc, nl) x = aperm(x, perm=c(2,1,3)) b <- brick(x) b <- flip(b, 'y') extent(b) <- extent(as.vector(apply(from$coords, 2, range))) b } ) setAs('grf', 'RasterLayer', function(from) { x <- from$data if (is.matrix(x)) { x <- x[,1] } ncell <- length(x) nc <- nr <- as.integer(sqrt(ncell)) dim(x) <- c(nr, nc) x <- t(x)[nrow(x):1,] r <- raster(x) extent(r) <- extent(as.vector(apply(from$coords, 2, range))) r } )
48 commonDataType.R
# Author: Robert J. Hijmans # Date : October 2011 # Version 1.0 # Licence GPL v3 .commonDataType <- function(dtype) { dtype <- as.vector(unlist(dtype)) dtype <- unique(dtype) if (length(dtype)==1) { datatype <- dtype } else { dsize <- dataSize(dtype) dtype <- .shortDataType(dtype) if (any(dtype == 'FLT')) { dsize <- max(dsize[dtype=='FLT']) datatype <- paste('FLT', dsize, 'S', sep='') } else { signed <- dataSigned(dtype) dsize <- max(dsize) if (all(signed)) { datatype <- paste('INT', dsize, 'S', sep='') } else if (all(!signed)) { datatype <- paste('INT', dsize, 'U', sep='') } else { dsize <- ifelse(dsize == 1, 2, ifelse(dsize == 2, 4, 8)) datatype <- paste('INT', dsize, 'S', sep='') } } } datatype }
49 compareCRS.R
# author Robert Hijmans # June 2010 # version 1.0 # license GPL3 .compareCRS <- function(...) { warning('use compareCRS, not .compareCRS') compareCRS(...) } compareCRS <- function(x, y, unknown=FALSE, verbatim=FALSE, verbose=FALSE) { x <- tolower(projection(x)) y <- tolower(projection(y)) step1 <- function(z) { z <- gsub(' ', '', z) if (!verbatim) { z <- unlist( strsplit(z, '+', fixed=TRUE) )[-1] z <- do.call(rbind, strsplit(z, '=')) } z } if (verbatim) { if (!is.na(x) & !is.na(y)) { return(x==y) } else { if (is.na(x) & is.na(y)) { return(TRUE) # ?? } else if (unknown) { return(TRUE) } else { return(FALSE) } } } x <- step1(x) y <- step1(y) if (length(x) == 0 & length(y) == 0) { return(TRUE) } else if (length(x) == 0 | length(y) == 0) { if (unknown) { return(TRUE) } else { if (verbose) { cat('Unknown CRS\n') } return(FALSE) } } x <- x[x[,1] != 'towgs84', , drop=FALSE] x <- x[x[,1] != 'no_defs', , drop=FALSE] x <- x[which(x[,1] %in% y[,1]), ,drop=FALSE] y <- y[which(y[,1] %in% x[,1]), ,drop=FALSE] x <- x[order(x[,1]), ,drop=FALSE] y <- y[order(y[,1]), ,drop=FALSE] i <- x[,2] == y[,2] if (! all(i)) { if (verbose) { i <- which(!i) for (j in i) { cat('+',x[j,1], ': ', x[j,2],' != ', y[j,2], '\n', sep='') } } return(FALSE) } return(TRUE) }
50 compare_Logical.R
# Authors: Robert J. Hijmans, r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 .getAdjustedE <- function(r, tr, i, e) { startcell <- cellFromRowCol(r, tr$row[i] , 1) len <- cellFromRowCol(r, tr$row[i] + (tr$nrows[i]-1), ncol(r)) - startcell + 1 n <- (startcell / length(e)) %% 1 if (n > 0 ) { start <- round(n * length(e)) } else { start <- 1 } out <- c(e[start:length(e)], rep(e, floor(len/length(e)))) out[1:len] } .asLogical <- function(x) { x[x!=0] <- 1 return(x) } setMethod('==', signature(e1='BasicRaster', e2='BasicRaster'), function(e1,e2){ cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) return(cond) } ) setMethod('!=', signature(e1='BasicRaster', e2='BasicRaster'), function(e1,e2){ cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) return(!cond) } ) setMethod('!', signature(x='Raster'), function(x){ if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return(setValues(r, ! getValues(x))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- ! .asLogical(getValues(x, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod(Compare, signature(e1='Raster', e2='logical'), function(e1,e2){ nl <- nlayers(e1) if (nl > 1) { r <- brick(e1, values=FALSE) } else { r <- raster(e1) } if (length(e2) > 1 & nl > 1) { if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(callGeneric(t(getValues(e1)), e2 ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } r <- setValues(r, values=callGeneric(getValues(e1), e2 ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod(Compare, signature(e1='logical', e2='Raster'), function(e1,e2){ callGeneric(e2, e1) } ) setMethod(Compare, signature(e1='Raster', e2='numeric'), function(e1, e2){ nl <- nlayers(e1) if (nl > 1) { r <- brick(e1, values=FALSE) } else { r <- raster(e1) } if (length(e2) > 1 & nl > 1) { if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(callGeneric(t(getValues(e1)), e2 ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } r <- setValues(r, values=callGeneric(getValues(e1), e2)) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod(Compare, signature(e1='numeric', e2='Raster'), function(e1,e2){ callGeneric(e2, e1) } ) setMethod(Compare, signature(e1='Raster', e2='Raster'), function(e1, e2){ if (nlayers(e1) > 1) { if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) { stop('number of layers of objects do not match') } r <- brick(e1, values=FALSE) } else if (nlayers(e2) > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e1) } cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) if (!cond) { stop(Cannot compare Rasters that have different BasicRaster attributes. See compare()) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, callGeneric(getValues(e1), getValues(e2))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) setMethod(Logic, signature(e1='Raster', e2='Raster'), function(e1, e2){ if (nlayers(e1) > 1) { r <- brick(e1, values=FALSE) if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) { stop('number of layers of objects do not match') } } else if (nlayers(e2) > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e1) } cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) if (!cond) { stop(Cannot compare Rasters that have different BasicRaster attributes. See compare()) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, callGeneric(.asLogical(getValues(e1)), .asLogical(getValues(e2)))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- callGeneric(.asLogical(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), .asLogical(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) setMethod(Compare, signature(e1='Extent', e2='Extent'), function(e1,e2){ a <- callGeneric(e2@xmin, e1@xmin) b <- callGeneric(e1@xmax, e2@xmax) c <- callGeneric(e2@ymin, e1@ymin) d <- callGeneric(e1@ymax, e2@ymax) a & b & c & d } )
51 compare.R
# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(all.equal)) { setGeneric(all.equal, function(target, current, ...) standardGeneric(all.equal)) } setMethod(all.equal, c(Raster, Raster), function(target, current, values=TRUE, stopiffalse=FALSE, showwarning=TRUE, ...) { compareRaster(target, current, ..., values=values, stopiffalse=stopiffalse, showwarning=showwarning) } ) compareRaster <- function(x, ..., extent=TRUE, rowcol=TRUE, crs=TRUE, res=FALSE, orig=FALSE, rotation=TRUE, values=FALSE, tolerance, stopiffalse=TRUE, showwarning=FALSE) { if (missing(tolerance)) { tol <- .tolerance() } else { tol <- tolerance } result <- TRUE objects <- c(x, list(...)) if (!isTRUE(length(objects) > 1)) { warning('There should be at least 2 Raster* objects to compare') return(result) } minres <- min(res(objects[[1]])) proj1 <- projection(objects[[1]]) ext1 <- extent(objects[[1]]) ncol1 <- ncol(objects[[1]]) nrow1 <- nrow(objects[[1]]) res1 <- res(objects[[1]]) origin1 <- abs(origin(objects[[1]])) rot1 <- rotated(objects[[1]]) for (i in 2:length(objects)) { if (extent) { if (!(isTRUE(all.equal(ext1, extent(objects[[i]]), tolerance=tol, scale=minres )))) { result <- FALSE if (stopiffalse) { stop('different extent') } if (showwarning) { warning('different extent') } } } if (rowcol) { if ( !(identical(ncol1, ncol(objects[[i]]))) ) { result <- FALSE if (stopiffalse) { stop('different number or columns') } if (showwarning) { warning('different number or columns') } } if ( !(identical(nrow1, nrow(objects[[i]]))) ) { result <- FALSE if (stopiffalse) { stop('different number or rows') } if (showwarning) { warning('different number or rows') } } } if (crs) { thisproj <- projection(objects[[i]]) if (is.na(proj1)) { proj1 <- thisproj } else { crs <- try (compareCRS(proj1, thisproj, unknown=TRUE), silent=TRUE) if (class(crs) == 'try-error') { if (stopiffalse) { stop('invalid CRS') } if (showwarning) { warning('invalid CRS') } } else if (!crs) { result <- FALSE if (stopiffalse) { stop('different CRS') } if (showwarning) { warning('different CRS') } } } } # Can also check res through extent & rowcol if (res) { if (!(isTRUE(all.equal(res1, res(objects[[i]]), tolerance=tol, scale=minres)))) { result <- FALSE if (stopiffalse) { stop('different resolution') } if (showwarning) { warning('different resolution') } } } # Can also check orig through extent & rowcol, but orig is useful for e.g. Merge(raster, raster) if (orig) { dif <- origin1 - abs(origin(objects[[i]])) if (!(isTRUE(all.equal(dif, c(0,0), tolerance=tol, scale=minres)))) { result <- FALSE if (stopiffalse) { stop('different origin') } if (showwarning) { warning('different origin') } } } if (rotation) { rot2 <- rotated(objects[[i]]) if (rot1 | rot2) { if (rot1 != rot2) { if (stopiffalse) { stop('not all objects are rotated') } if (showwarning) { warning('not all objects are rotated') } result <- FALSE } else { test <- all(objects[[i]]@rotation@geotrans == objects[[1]]@rotation@geotrans) if (! test) { if (stopiffalse) { stop('rotations are different') } if (showwarning) { warning('rotations are different') } result <- FALSE } } } } if (values) { hv1 <- hasValues(objects[[1]]) hvi <- hasValues(objects[[i]]) if (hv1 != hvi) { if (stopiffalse) { stop('not all objects have values') } if (showwarning) { warning('not all objects have values') } result <- FALSE } else if (hv1 & hvi) { if (canProcessInMemory(objects[[1]])) { test <- isTRUE(all.equal(getValues(objects[[1]]), getValues(objects[[i]]))) if (! test) { if (stopiffalse) { stop('not all objects have the same values') } if (showwarning) { warning('not all objects have the same values') } result <- FALSE } } else { tr <- blockSize(objects[[1]]) for (j in 1:tr$n) { v1 <- getValues(objects[[1]], tr$row[j], tr$nrows[j]) v2 <- getValues(objects[[i]], tr$row[j], tr$nrows[j]) if (!isTRUE(all.equal(v1, v2))) { if (stopiffalse) { stop('not all objects have the same values') } if (showwarning) { warning('not all objects have the same values') } result <- FALSE break } } } } } } return(result) }
52 connection.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(readStart)) { setGeneric(readStart, function(x, ...) standardGeneric(readStart)) } setMethod('readStart', signature(x='Raster'), function(x, ...) { if ( fromDisk(x) ) { return (.openConnection(x, ...)) } else { return(x) } } ) setMethod('readStart', signature(x='RasterStack'), function(x, ..., maxopen=100) { fd <- sapply(x@layers, fromDisk) ld <- sum(fd) if (isTRUE( ld > 0 & ld <= maxopen)) { d <- which(fd) for (i in d) { x@layers[[i]] <- readStart(x@layers[[i]], con.check=103, ...) } } x } ) .openConnection <- function(x, silent=TRUE, con.check=Inf, ...) { fn <- trim(x@file@name) driver <- .driver(x) if (driver == gdal) { attr(x@file, con) <- rgdal::GDAL.open(fn, silent=silent) x@file@open <- TRUE } else if (.isNativeDriver(driver)) { # R has a max of 128 connections if (length(getAllConnections()) < con.check) { fn <- .setFileExtensionValues(fn, driver) attr(x@file, con) <- file(fn, rb) x@file@open <- TRUE } } else if (driver == 'netcdf') { if (isTRUE(getOption('rasterNCDF4'))) { attr(x@file, 'con') <- ncdf4::nc_open(x@file@name) } else { attr(x@file, 'con') <- ncdf::open.ncdf(x@file@name) } x@file@open <- TRUE # } else if (driver == 'ascii') { # cannot be opened } x } if (!isGeneric(readStop)) { setGeneric(readStop, function(x, ...) standardGeneric(readStop)) } setMethod('readStop', signature(x='Raster'), function(x, ...) { if ( fromDisk(x) ) { return (.closeConnection(x)) } else { return(x) } } ) setMethod('readStop', signature(x='RasterStack'), function(x, ...) { d <- which(sapply(x@layers, fromDisk)) if (length(d) > 0) { for (i in d) { x@layers[[i]] <- readStop(x@layers[[i]], ...) } } x } ) .closeConnection <- function(x) { driver <- .driver(x) if (driver == gdal) { try( rgdal::closeDataset(x@file@con), silent = TRUE ) } else if (.isNativeDriver(driver)) { try( close(x@file@con), silent = TRUE ) } else if (driver == 'netcdf') { if (isTRUE(getOption('rasterNCDF4'))) { ncdf4::nc_close(x@file@con) } else { ncdf::close.ncdf(x@file@con) } } else if (driver == 'ascii') { } x@file@open <- FALSE attr(x@file, 'con') <- NULL x # attr(x@file, con <- ) }
53 contour.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : April 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(contour)) { setGeneric(contour, function(x,...) standardGeneric(contour)) } setMethod(contour, signature(x='RasterLayer'), function(x, maxpixels=100000, ...) { x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) contour(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...) } ) rasterToContour <- function(x, maxpixels=100000, ...) { x <- sampleRegular(x, size=maxpixels, asRaster=TRUE, useGDAL=TRUE) cL <- contourLines(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...) # The below was taken from ContourLines2SLDF(maptools), by Roger Bivand & Edzer Pebesma .contourLines2LineList <- function(cL) { n <- length(cL) res <- vector(mode=list, length=n) for (i in 1:n) { crds <- cbind(cL[[i]][[2]], cL[[i]][[3]]) res[[i]] <- Line(coords=crds) } res } if (length(cL) < 1) stop(no contour lines) cLstack <- tapply(1:length(cL), sapply(cL, function(x) x[[1]]), function(x) x, simplify = FALSE) df <- data.frame(level = names(cLstack)) m <- length(cLstack) res <- vector(mode = list, length = m) IDs <- paste(C, 1:m, sep = _) row.names(df) <- IDs for (i in 1:m) { res[[i]] <- Lines(.contourLines2LineList(cL[cLstack[[i]]]), ID = IDs[i]) } SL <- SpatialLines(res, proj4string = projection(x, asText=FALSE)) SpatialLinesDataFrame(SL, data = df) } filledContour <- function(x, y=1, maxpixels=100000, ...) { if (nlayers(x) > 1) { y <- min(max(1, y), nlayers(x)) x <- raster(x, y) } x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) X <- xFromCol(x, 1:ncol(x)) Y <- yFromRow(x, nrow(x):1) Z <- t( matrix( getValues(x), ncol=x@ncols, byrow=TRUE)[nrow(x):1,] ) filled.contour(x=X,y=Y,z=Z,...) }
54 corLocal.R
# Author: Robert J. Hijmans # Date : February 2014 # Version 1.0 # Licence GPL v3 if ( !isGeneric(corLocal) ) { setGeneric(corLocal, function(x, y, ...) standardGeneric(corLocal)) } setMethod('corLocal', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ngb=5, method = c(pearson, kendall, spearman), test=FALSE, filename='', ...) { compareRaster(x,y) if (test) { out <- brick(x, values=FALSE, nl=2) names(out) <- c(method[1], 'p-value') } else { out <- raster(x) names(out) <- c(method[1]) } if (canProcessInMemory(x, n=2*ngb)) { vx <- getValuesFocal(x, 1, nrow(x), ngb=ngb) vy <- getValuesFocal(y, 1, nrow(y), ngb=ngb) if (test) { v <- matrix(NA, ncol=2, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { a <- cor.test(z[,1], z[,2], method=method) v[i, ] <- c(a$estimate, a$p.value) } } } else { v <- rep(NA, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { v[i] <- cor(z[,1], z[,2], method=method) } } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='corLocal', ...) out <- writeStart(out, filename=filename, ...) if (test) { for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- matrix(NA, ncol=2, nrow=nrow(vx)) for (j in 1:nrow(vx)) { z <- na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { a <- cor.test(z[,1], z[,2], method=method) v[j, ] <- c(a$estimate, a$p.value) } } out <- writeValues(out, v, tr$row[i]) } } else { for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- rep(NA, nrow(vx)) for (j in 1:length(v)) { z <- na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { v[j] <- cor(z[,1], z[,2], method=method) } } out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } ) setMethod('corLocal', signature(x='RasterStackBrick', y='RasterStackBrick'), function(x, y, method = c(pearson, kendall, spearman), test=FALSE, filename='', ...) { compareRaster(x,y) nl1 <- nlayers(x) nl2 <- nlayers(y) if (nl1 != nl2) { stop('nlayers does not match') } if (nl1 < 3) { stop('number of layers should be > 2') } if (test) { out <- brick(x, values=FALSE, nl=2) names(out) <- c(method[1], 'p-value') } else { out <- raster(x) names(out) <- c(method[1]) } if (canProcessInMemory(x)) { vx <- getValues(x) vy <- getValues(y) if (test) { v <- matrix(NA, ncol=2, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { a <- cor.test(z[,1], z[,2], method=method) v[i, ] <- c(a$estimate, a$p.value) } } } else { v <- rep(NA, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { v[i] <- cor(z[,1], z[,2], method=method) } } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='corLocal', ...) out <- writeStart(out, filename=filename, ...) if (test) { for (i in 1:tr$n) { vx <- getValues(x, tr$row[i], tr$nrows[i]) vy <- getValues(y, tr$row[i], tr$nrows[i]) v <- matrix(NA, ncol=2, nrow=nrow(vx)) for (j in 1:nrow(vx)) { z <- na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { a <- cor.test(z[,1], z[,2], method=method) v[j, ] <- c(a$estimate, a$p.value) } } out <- writeValues(out, v, tr$row[i]) } } else { for (i in 1:tr$n) { vx <- getValues(x, tr$row[i], tr$nrows[i]) vy <- getValues(y, tr$row[i], tr$nrows[i]) v <- rep(NA, nrow(vx)) for (j in 1:length(v)) { z <- na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { v[j] <- cor(z[,1], z[,2], method=method) } } out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } )
55 cor.R
.cor <- function(x, n=Inf, ...) { nl <- nlayers(x) if (nl < 2) return(1) if (n < ncell(x)) { x <- sampleRegular(x, size=n, asRaster=TRUE) } if (canProcessInMemory(x, nlayers(x)*4)) { s <- na.omit(getValues(x)) s <- cor(s) } else { msk <- sum(x, na.rm=FALSE) x <- mask(x, msk) mx <- cellStats(x, mean) sx <- cellStats(x, sd) nc <- ncell(x) s <- matrix(NA, nrow=n, ncol=n) for (i in 1:(nl-1)) { for (j in (i+1):nl) { s[j,i] <- s[i,j] <- cellStats(((x[[i]] - mx[i]) * (x[[j]] - mx[j])) / (sx[i] * sx[j]), sum)/ (nc-1) } } diag(s) <- 1 } if (nrow(s) == 2) { s[2,1] } else { colnames(s) <- rownames(s) <- names(x) s } }
56 coverBrick.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(cover)) { setGeneric(cover, function(x, y, ...) standardGeneric(cover)) } setMethod('cover', signature(x='RasterStackBrick', y='Raster'), function(x, y, ..., filename=''){ rasters <- .makeRasterList(x, y, ..., unstack=FALSE) nl <- sapply(rasters, nlayers) un <- unique(nl) if (length(un) > 3) { stop('number of layers does not match') } else if (length(un) == 2 & min(un) != 1) { stop('number of layers does not match') } else if (nl[1] != max(un)) { stop('number of layers of the first object must be the highest') } outRaster <- brick(x, values=FALSE) filename <- trim(filename) dots <- list(...) if (is.null(dots$format)) { format <- .filetype(format=format, filename=filename) } else { format <- dots$format } if (is.null(dots$overwrite)) { overwrite <- .overwrite() } else { overwrite <- dots$overwrite } if (is.null(dots$progress)) { progress <- .progress() } else { progress <- dots$progress } if (is.null(dots$datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } else { datatype <- dots$datatype } if ( canProcessInMemory(x, sum(nl)+nl[1])) { v <- getValues( rasters[[1]] ) v2 <- v for (j in 2:length(rasters)) { v2[] <- getValues( rasters[[j]] ) v[is.na(v)] <- v2[is.na(v)] } outRaster <- setValues(outRaster, v) if (filename != '') { outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } } else { if (filename == '') { filename <- rasterTmpFile() } outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite) tr <- blockSize(outRaster, sum(nl)) pb <- pbCreate(tr$n, label='cover', progress=progress) for (i in 1:tr$n) { v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] ) v2 <- v for (j in 2:length(rasters)) { v2[] <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i]) v[is.na(v)] <- v2[is.na(v)] } outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) outRaster <- writeStop(outRaster) } return(outRaster) } )
57 coverPolygons.R
# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric(cover)) { setGeneric(cover, function(x, y, ...) standardGeneric(cover)) } setMethod('cover', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ..., identity=FALSE){ stopifnot(require(rgeos)) yy <- list(y, ...) i <- which(sapply(yy, function(x) inherits(x, 'SpatialPolygons'))) if (length(i)==0) { stop('additional arguments should be of class SpatialPolygons') } else if (length(i) < length(yy)) { warning('additional arguments that are not of class SpatialPolygons are ignored') yy <- yy[i] } if (identity) { return(.coverIdentity(x, yy)) } haswarned <- FALSE for (y in yy) { if (! identical(proj4string(x), proj4string(y)) ) { if (!haswarned) { warning('non identical CRS') haswarned <- TRUE } y@proj4string <- x@proj4string } subs <- rgeos::gIntersects(x, y, byid=TRUE) if (!any(subs)) { next } else { int <- crop(y, x) x <- erase(x, int) x <- bind(x, int) } } x } ) .coverIdentity <- function(x, yy) { haswarned <- FALSE for (y in yy) { if (! identical(proj4string(x), proj4string(y)) ) { if (!haswarned) { warning('non identical CRS') haswarned <- TRUE } y@proj4string <- x@proj4string } i <- rgeos::gIntersects(x, y) if (!i) { next } x <- spChFIDs(x, as.character(1:length(x))) y <- spChFIDs(y, as.character(1:length(y))) if (.hasSlot(x, 'data')) { xnames <- colnames(x@data) } else { xnames <-NULL } if (.hasSlot(y, 'data')) { ynames <- colnames(y@data) } else { ynames <-NULL } if (is.null(xnames) & !is.null(ynames)) { dat <- y@data[NULL, ,drop=FALSE] dat[1:length(x), ] <- NA x <- SpatialPolygonsDataFrame(x, dat) xnames <- ynames } yinx <- which(ynames %in% xnames) doAtt <- TRUE if (length(yinx) == 0) { doAtt <- FALSE } subs <- rgeos::gIntersects(x, y, byid=TRUE) subsx <- apply(subs, 2, any) subsy <- apply(subs, 1, any) int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_not_poly=TRUE) #if (inherits(int, SpatialCollections)) { # if (is.null(int@polyobj)) { # ?? # warning('polygons do not intersect') # next # } # int <- int@polyobj #} if (!inherits(int, 'SpatialPolygons')) { warning('polygons do not intersect') next } if (doAtt) { ids <- do.call(rbind, strsplit(row.names(int), ' ')) idsy <- match(ids[,2], rownames(y@data)) rows <- 1:length(idsy) dat <- x@data[NULL, ,drop=FALSE] dat[rows, yinx] <- y@data[idsy, yinx] int <- SpatialPolygonsDataFrame(int, dat, match.ID=FALSE) } x <- erase(x, int) if (is.null(x)) { x <- int } else { x <- bind(x, int) } } x }
58 cover.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(cover)) { setGeneric(cover, function(x, y, ...) standardGeneric(cover)) } setMethod('cover', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ..., filename=''){ rasters <- .makeRasterList(x, y, ...) nl <- sapply(rasters, nlayers) if (max(nl) > 1) { stop(Only single layer (RasterLayer) objects can be used if 'x' and 'y' have a single layer) } outRaster <- raster(x) compareRaster(c(outRaster, rasters)) filename <- trim(filename) dots <- list(...) if (is.null(dots$format)) { format <- .filetype(filename=filename) } else { format <- dots$format } if (is.null(dots$overwrite)) { overwrite <- .overwrite() } else { overwrite <- dots$overwrite } if (is.null(dots$progress)) { progress <- .progress() } else { progress <- dots$progress } if (is.null(dots$datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } else { datatype <- dots$datatype } if (canProcessInMemory(x, length(rasters) + 2)) { v <- getValues( rasters[[1]] ) for (j in 2:length(rasters)) { v[is.na(v)] <- getValues(rasters[[j]])[is.na(v)] } outRaster <- setValues(outRaster, v) if (filename != '') { outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } } else { if (filename == '') { filename <- rasterTmpFile() } outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite ) tr <- blockSize(outRaster, length(rasters)) pb <- pbCreate(tr$n, progress=progress, label='cover') for (i in 1:tr$n) { v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] ) if (! is.matrix(v) ) { v <- matrix(v, ncol=1) } for (j in 2:length(rasters)) { vv <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i]) v[is.na(v)] <- vv[is.na(v)] } outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) outRaster <- writeStop(outRaster) } return(outRaster) } )
59 crop.R
# Authors: Robert J. Hijmans and Jacob van Etten # Date : October 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(crop)) { setGeneric(crop, function(x, y, ...) standardGeneric(crop)) } .copyWithProperties <- function(x) { if (inherits(x, 'RasterStackBrick')) { out <- brick(x, values=FALSE) } else { out <- raster(x) out@legend <- x@legend } names(out) <- names(x) out <- setZ(out, getZ(x)) fx <- is.factor(x) if (isTRUE(any(fx))) { out@data@isfactor <- fx out@data@attributes <- levels(x) } out } setMethod('crop', signature(x='Raster', y='ANY'), function(x, y, filename='', snap='near', datatype=NULL, ...) { filename <- trim(filename) y <- try ( extent(y), silent=TRUE ) if (class(y) == try-error) { stop('Cannot get an Extent object from argument y') } validObject(y) out <- .copyWithProperties(x) leg <- out@legend e <- intersect(extent(x), extent(y)) if (is.null(e)) { stop('extents do not overlap') } e <- alignExtent(e, x, snap=snap) out <- setExtent(out, e, keepres=TRUE) if (! hasValues(x)) { return(out) } col1 <- colFromX(x, xmin(out)+0.5*xres(out)) col2 <- colFromX(x, xmax(out)-0.5*xres(out)) row1 <- rowFromY(x, ymax(out)-0.5*yres(out)) row2 <- rowFromY(x, ymin(out)+0.5*yres(out)) if (row1==1 & row2==nrow(x) & col1==1 & col2==ncol(x)) { return(x) } nc <- ncol(out) nr <- row2 - row1 + 1 if (is.null(datatype)) { datatype <- unique(c(dataType(x), 'INT2S')) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } dataType(out) <- datatype xx <- out xx@ncols <- x@ncols # getValuesBlock might read entire rows and then subset if (canProcessInMemory(xx, 4)) { v <- getValuesBlock(x, row1, nrows=nr, col=col1, ncols=nc) out <- setValues(out, v) if (filename != ) { out <- writeRaster(out, filename=filename, datatype=datatype, ...) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='crop', ...) out <- writeStart(out, filename=filename, datatype=datatype, ... ) x <- readStart(x, ...) for (i in 1:tr$n) { vv <- getValuesBlock(x, row=tr$row[i]+row1-1, nrows=tr$nrows[i], col1, nc) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) x <- readStop(x) pbClose(pb) } out@legend <- leg return(out) } )
60 cropSpatial.R
# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod('crop', signature(x='Spatial', y='ANY'), function(x, y, ...) { if (! inherits(y, 'SpatialPolygons')) { if (inherits(y, 'Extent')) { y <- as(y, 'SpatialPolygons') y@proj4string <- x@proj4string } else { y <- extent(y) validObject(y) y <- as(y, 'SpatialPolygons') } y@proj4string <- x@proj4string } if (! compareCRS(x, y) ) { warning('non identical CRS') } y@proj4string <- x@proj4string if (inherits(x, 'SpatialPolygons')) { stopifnot(require(rgeos)) .cropSpatialPolygons(x, y, ...) } else if (inherits(x, 'SpatialLines')) { stopifnot(require(rgeos)) .cropSpatialLines(x, y, ...) } else if (inherits(x, 'SpatialPoints')) { .cropSpatialPoints(x, y, ...) } else { return( x[y] ) } } ) .cropSpatialPolygons <- function(x, y, ...) { y <- rgeos::gUnaryUnion(y) row.names(y) <- '1' rnx <- row.names(x) row.names(x) <- as.character(1:length(rnx)) if (.hasSlot(x, 'data')) { # to keep the correct IDs # in future versions of rgeos, this intermediate step won't be necessary i <- as.vector( rgeos::gIntersects(x, y, byid=TRUE) ) if (sum(i) == 0) { return(NULL) } y <- rgeos::gIntersection(x[i,], y, byid=TRUE) if (inherits(y, SpatialCollections)) { y <- y@polyobj } if (is.null(y)) { return(y) } ids <- strsplit(row.names(y), ' ') ids <- as.numeric(do.call(rbind, ids)[,1]) row.names(y) <- as.character(rnx[ids]) data <- x@data[ids, ,drop=FALSE] rownames(data) <- rnx[ids] return( SpatialPolygonsDataFrame(y, data) ) } else { y <- rgeos::gIntersection(x, y, drop_not_poly=TRUE) #if (inherits(y, SpatialCollections)) { # y <- y@polyobj #} return(y) } } .cropSpatialLines <- function(x, y, ...) { rnx <- row.names(x) row.names(x) <- as.character(1:length(rnx)) if (.hasSlot(x, 'data')) { # in future versions of rgeos, this intermediate step should not be necessary i <- as.vector( rgeos::gIntersects(x, y, byid=TRUE) ) if (sum(i) == 0) { return(NULL) } y <- rgeos::gIntersection(x[i,], y, byid=TRUE) if (inherits(y, SpatialCollections)) { y <- y@lineobj } ids <- strsplit(row.names(y), ' ') ids <- as.numeric(do.call(rbind, ids)[,1]) row.names(y) <- as.character(rnx[ids]) data <- x@data[ids, ,drop=FALSE] rownames(data) <- rnx[ids] SpatialLinesDataFrame(y, data) } else { y <- rgeos::gIntersection(x, y) if (inherits(y, SpatialCollections)) { y <- y@lineyobj } return(y) } } .cropSpatialPoints <- function(x, y, ...) { i <- which(!is.na(over(x, y))) if (length(i) > 0) { x <- x[i,] } else { x <- NULL } x }
61 crosstab.R
# Author: Robert J. Hijmans # Date : March 2009 # Version 1.0 # Licence GPL v3 # revised April 2011 if (!isGeneric(crosstab)) { setGeneric(crosstab, function(x, y, ...) standardGeneric(crosstab)) } setMethod('crosstab', signature(x='Raster', y='Raster'), function(x, y, digits=0, long=FALSE, useNA=FALSE, progress='', ...) { x <- stack(x, y) crosstab(x, digits=digits, long=long, useNA=useNA, progress=progress, ...) } ) setMethod('crosstab', signature(x='RasterStackBrick', y='missing'), function(x, digits=0, long=FALSE, useNA=FALSE, progress='', ...) { nl <- nlayers(x) if (nl < 2) { stop('crosstab needs at least 2 layers') } nms <- names(x) if (canProcessInMemory(x)) { res <- getValues(x) res <- lapply(1:nl, function(i) round(res[, i], digits=digits)) res <- do.call(table, c(res, useNA='always')) res <- as.data.frame(res) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='crosstab', progress=progress) res <- NULL for (i in 1:tr$n) { d <- getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) d <- lapply(1:nl, function(i) round(d[, i], digits=digits)) d <- do.call(table, c(d, useNA='always')) d <- as.data.frame(d) res <- rbind(res, d) pbStep(pb, i) } pbClose(pb) if (nrow(res) == 0) { res <- data.frame(matrix(nrow=0, ncol=length(nms)+1)) } colnames(res) <- c(nms, 'Freq') if (! useNA ) { i <- which(apply(res, 1, function(x) sum(is.na(x))>0)) res <- res[-i, ,drop=FALSE] } # keep NA classes if there are any for (i in 1:(ncol(res)-1)) { if (any(is.na(res[,i]))) { res[,i] <- factor(res[,i], levels=c(levels(res[,i]), NA), exclude=NULL) } } f <- eval(parse(text=paste('Freq ~ ', paste(nms , collapse='+')))) res <- xtabs(f, data=res) } if (long) { if (nrow(res) > 1) { res <- data.frame(res) colnames(res) <- c(nms, 'Freq') res <- res[res$Freq > 0, ,drop=FALSE] } } return(res) } ) .oldcrosstab <- function(x, y, digits=0, long=FALSE, progress, ...) { # old function, not used any more compareRaster(c(x, y)) if (missing(progress)) { progress <- .progress() } if (canProcessInMemory(x, 3) | ( inMemory(x) & inMemory(y) )) { res <- table(first=round(getValues(x), digits=digits), second=round(getValues(y), digits=digits), ...) } else { res <- NULL tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='crosstab', progress=progress) for (i in 1:tr$n) { d <- table( round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), round(getValuesBlock(y, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), ...) if (length(dim(d))==1) { first = as.numeric(names(d)) second = first d <- matrix(d) } else { first = as.numeric(rep(rownames(d), each=ncol(d))) second = as.numeric(rep(colnames(d), times=nrow(d))) } count = as.vector(t(d)) res = rbind(res, cbind(first, second, count)) pbStep(pb, i) } pbClose(pb) res = xtabs(count~first+second, data=res) } if (long) { return( as.data.frame(res) ) } else { return(res) } }
62 cut.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(cut)) { setGeneric(cut, function(x, ...) standardGeneric(cut)) } setMethod('cut', signature(x='Raster'), function(x, breaks, ..., filename='', format, datatype='INT2S', overwrite, progress) { if (! hasValues(x) ) { warning('x has no values, nothing to do') return(x) } filename <- trim(filename) if (missing(format)) { format <- .filetype(format=format, filename=filename) } if (missing(overwrite)) { overwrite <- .overwrite() } if (missing(progress)) { progress <- .progress() } nl <- nlayers(x) if (nl == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) } if (canProcessInMemory(out, n=nl*2 + 2)) { if (nl > 1) { values(out) <- apply(getValues(x), 2, function(x) as.numeric(cut(x, breaks=breaks, ...))) } else { values(out) <- as.numeric(cut(getValues(x), breaks=breaks, ...)) } if ( filename != ) { out <- writeRaster(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } if (length(breaks) == 1) { breaks <- round(breaks) stopifnot(breaks > 1) probs <- c(0, 1:breaks * 1/breaks) breaks <- na.omit(sampleRegular(x, 10000, useGDAL=TRUE)) warning('breaks are approximate, based on a sample of ', length(breaks), ' cells that are not NA') breaks <- quantile(, probs, names=FALSE) breaks[1] <- -Inf breaks[length(breaks)] <- Inf } out <- writeStart(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) tr <- blockSize(out) pb <- pbCreate(tr$n, progress=progress, label='cut') if (nl > 1) { for (i in 1:tr$n) { res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) res <- apply(res, 2, function(x) as.numeric(cut(x, breaks=breaks, ...))) out <- writeValues(out, res, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) res <- as.numeric(cut(res, breaks=breaks, ...)) out <- writeValues(out, res, tr$row[i]) pbStep(pb, i) } } out <- writeStop(out) pbClose(pb) return(out) } } )
63 cv.R
# Author: Robert J. Hijmans # Date : October 2008-2011 # Version 1.0 # Licence GPL v3 setGeneric(cv, function(x, ..., aszero=FALSE, na.rm=FALSE) standardGeneric(cv)) setMethod('cv', signature(x='ANY'), function(x, ..., aszero=FALSE, na.rm=FALSE) { # R function to compute the coefficient of variation (expressed as a percentage) # if there is only a single value, sd = NA. However, one could argue that cv =0. # and NA may break the code that receives it. #The function returns NA if(aszero=FALSE) else a value of 0 is returned. x <- c(x, ...) z <- x[!is.na(x)] if (length(z) == 0) { return(NA) } else if (na.rm == FALSE & (length(z) < length(x))) { return(NA) } else if (length(z) == 1 & aszero == TRUE) { return(0) } else { x <- mean(z) if (x == 0) { return(NA) } else { return(100 * sd(z) / x) } } } ) setMethod(cv, signature(x='Raster'), function(x, ..., aszero=FALSE, na.rm=FALSE){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- .addArgs(...) } else { add <- NULL } out <- raster(x) if (canProcessInMemory(x)) { x <- cbind(getValues(x), add) x <- setValues(out, apply(x, 1, cv, aszero=aszero, na.rm=na.rm)) return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n) out <- writeStart(out, filename=) for (i in 1:tr$n) { v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add) v <- apply(v, 1, cv, aszero=aszero, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) writeStop(out) } )
64 dataProperties.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 #dataSize <- function(object) {return(object@file@datasize)} dataSize <- function(object) { if (class(object) != 'character'){ object <- dataType(object) } return( as.integer (substr(object, 4, 4)) ) } dataSigned <- function(object) { if (class(object) != 'character') { object <- dataType(object) } ifelse(substr(object, 5, 5) == 'U', FALSE, TRUE ) } .shortDataType <- function(object) { if (class(object) != 'character') { object <- dataType(object) } return( substr(object, 1, 3)) } dataType <- function(x) { if (inherits(x, 'RasterStack')) { return(sapply(x@layers, function(x) x@file@datanotation)) } else { return(x@file@datanotation) } } ..dataIndices <- function(object) { # return(object@data@indices) } fromDisk <- function(x) { if (inherits( x, 'RasterStack' )) { return( all( sapply( x@layers, function(x) x@data@fromdisk ))) } else { return( x@data@fromdisk ) } } inMemory <- function(x) { if (inherits( x, 'RasterStack' )) { return( all( sapply( x@layers, function(x) x@data@inmemory ))) } else { return( x@data@inmemory ) } } hasValues <- function(x) { if (class(x) == 'BasicRaster') { return(FALSE) } if (inherits(x, 'RasterStack')) { if (nlayers(x) > 0) return(TRUE) else return(FALSE) } if ( fromDisk(x) | inMemory(x) ) { return(TRUE) } else { return(FALSE) } }
65 dataType.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 'dataType<-' <- function(x, value) { if (inherits(x, 'RasterStack')) { stop('Cannot set datatype of a RasterStack') } # for backward compatibility issues and non fatal mistakes. datatype <- substr( toupper( trim(value) ), 1, 5) if (datatype == 'LOGIC') {datatype <- 'LOG1S' } else if (datatype == 'BYTE') {datatype <- 'INT1U' } else if (datatype == 'SMALL') {datatype <- 'INT2S' } else if (datatype == 'INTEG') {datatype <- 'INT2S' } else if (datatype == 'NUMER') {datatype <- 'FLT4S' } else if (datatype == 'FLOAT') {datatype <- 'FLT4S' } else if (datatype == 'DOUBL') {datatype <- 'FLT8S' } else if (datatype == 'SINGL') {datatype <- 'FLT4S' } else if (datatype == 'REAL') {datatype <- 'FLT4S'} if (nchar(datatype) < 3) { stop(paste('invalid datatype:', datatype)) } else if (nchar(datatype) == 3) { if (datatype == 'LOG') { datatype <- paste(datatype, '1S', sep='') } else { datatype <- paste(datatype, '4S', sep='') } } else if (nchar(datatype) == 4) { if (datatype == 'INT1') { datatype <- paste(datatype, 'U', sep='') } else { datatype <- paste(datatype, 'S', sep='') } } # now for real if (!(substr(datatype, 1, 4) %in% c('LOG1', 'INT1', 'INT2', 'INT4', 'FLT4', 'FLT8'))) { stop('not a valid data type') } type <- substr(datatype,1,3) size <- substr(datatype,4,4) signed <- substr(datatype,5,5) != 'U' if (type == FLT) { # if (dataContent(x) != 'nodata') { # x@data@values[] <- as.numeric(x@data@values) # } if (size == '4') { x@file@datanotation <- 'FLT4S' x@file@nodatavalue <- -3.4E38 } else if (size == '8') { x@file@datanotation <- 'FLT8S' x@file@nodatavalue <- -1.7E308 } else { stop(invalid datasize for a FLT (should be 4 or 8)) } } else if (type == INT) { # x@data@min <- round(x@data@min) # x@data@max <- round(x@data@max) # if (dataContent(x) != 'nodata') { # x@data@values[] <- as.integer(round(x@data@values)) # } # } if (size == '4') { if (signed) { x@file@datanotation <- 'INT4S' x@file@nodatavalue <- -2147483647 } else { x@file@datanotation <- 'INT4U' x@file@nodatavalue <- 4294967295 } } else if (size == '2') { if (signed) { x@file@datanotation <- 'INT2S' x@file@nodatavalue <- -32768 } else { x@file@datanotation <- 'INT2U' x@file@nodatavalue <- 65535 } } else if (size == '1') { if (signed) { x@file@datanotation <- 'INT1S' x@file@nodatavalue <- as.double(NA) # no default NA value } else { x@file@datanotation <- 'INT1U' x@file@nodatavalue <- as.double(NA) # no default NA value } # } else if (size == '8') { # x@file@nodatavalue <- -9223372036854775808 # x@file@datanotation <- 'INT8S' } else { stop(invalid datasize for this datatype) } } else if ( type == 'LOG' ) { x@file@nodatavalue <- -128 x@file@datanotation <- 'LOG1S' } else { stop(unknown datatype) } return(x) }
66 density.R
# Author: Robert J. Hijmans # Date: December 2009 # Version 0.1 # Licence GPL v3 if (!isGeneric(density)) { setGeneric(density, function(x, ...) standardGeneric(density)) } setMethod('density', signature(x='Raster'), function(x, layer, maxpixels=100000, plot=TRUE, main, ...) { if (nlayers(x)==1) { d <- sampleRegular(x, maxpixels, useGDAL=TRUE) x <- density(na.omit(d)) if (plot) { if (missing(main)) { main='' } plot(x, main=main, ...) return(invisible(x)) } else { return(x) } } if (missing(layer)) { y <- 1:nlayers(x) } else if (is.character(layer)) { y <- match(layer, names(x)) } else { y <- layer } y <- unique(as.integer(round(y))) y <- na.omit(y) y <- y[ y >= 1 & y <= nlayers(x) ] nl <- length(y) if (nl == 0) {stop('no existing layers selected')} if (nl > 1) { res <- list() if (nl > 16) { warning('only the first 16 layers are plotted') nl <- 16 y <- y[1:16] } if (missing(main)) { main=names(x) } nc <- ceiling(sqrt(nl)) nr <- ceiling(nl / nc) mfrow <- par(mfrow) spots <- mfrow[1] * mfrow[2] if (spots < nl) { old.par <- par(no.readonly = TRUE) on.exit(par(old.par)) par(mfrow=c(nr, nc)) } for (i in 1:length(y)) { r <- raster(x, y[i]) m <- main[y[i]] res[[i]] <- density(r, maxpixels=maxpixels, main=m, plot=plot, ...) } } else if (nl==1) { if (missing(main)) { main <- names(x)[y] } r <- raster(x, y) res <- density(r, maxpixels=maxpixels, main=main, plot=plot, ...) } if (plot) return(invisible(res)) else return(res) } )
67 destair.R
.destair <- function(x, keepExtent=TRUE) { pts <- as.data.frame(as(x, 'SpatialPolygons'), xy=TRUE, centroids=FALSE) if (keepExtent) { bb <- bbox(x) ptsx1 <- pts[,5] == bb[1,1] ptsx2 <- pts[,5] == bb[1,2] ptsy1 <- pts[,6] == bb[2,1] ptsy2 <- pts[,6] == bb[2,2] } u <- unique(pts$cump) for (j in u) { k <- pts$cump==j p <- pts[k, 5:6] p <- rbind(p[(nrow(p)-1), ,drop=FALSE], p, p[2,,drop=FALSE]) dx <- diff(p$x) dy <- diff(p$y) tf1 <- rowSums( cbind(dx[-length(dx)], dy[-1]) ) tf2 <- rowSums( cbind(dx[-1], dy[-length(dy)]) ) i <- which(tf1==0 | tf2==0) + 1 p[i, ] <- (p[i-1, ] + p[i+1, ] + 2 * p[i, ]) / 4 pts[k, 5:6] <- p[-c(1, nrow(p)),] } if (keepExtent) { pts[ptsx1,5] <- bb[1,1] pts[ptsx2,5] <- bb[1,2] pts[ptsy1,6] <- bb[2,1] pts[ptsy2,6] <- bb[2,2] } r <- as(pts, 'SpatialPolygons') row.names(r) <- row.names(x) proj4string(r) <- proj4string(x) if (.hasSlot(x, 'data')) { r <- SpatialPolygonsDataFrame(r, x@data) } r }
68 detectCores.R
# File src/library/parallel/R/detectCores.R # Part of the R package, http://www.R-project.org # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # http://www.r-project.org/Licenses/ ## In part based on code in package multicore 0.1-6 by Simon Urbanek .detectCores <- if(.Platform$OS.type == windows) { function(all.tests = FALSE, logical = TRUE) { # This is a hack to stop the check NOTE: .detectCores: no visible global function definition for 'readRegistry' if (!exists('readRegistry')) { readRegistry <- function(...)(1) } length(readRegistry(HARDWARE\\DESCRIPTION\\System\\CentralProcessor, maxdepth=1)) } } else { function(all.tests = FALSE, logical = FALSE) { systems <- list(darwin = /usr/sbin/sysctl -n hw.ncpu 2>/dev/null, freebsd = /sbin/sysctl -n hw.ncpu 2>/dev/null, linux = grep processor /proc/cpuinfo 2>/dev/null | wc -l, irix = c(hinv | grep Processors | sed 's: .*::', hinv | grep '^Processor '| wc -l), solaris = if(logical) /usr/sbin/psrinfo -v | grep 'Status of.*processor' | wc -l else /bin/kstat -p -m cpu_info | grep :core_id | cut -f2 | uniq | wc -l) for (i in seq(systems)) if(all.tests || length(grep(paste(^, names(systems)[i], sep=''), R.version$os))) for (cmd in systems[i]) { a <- gsub(^ +,, system(cmd, TRUE)[1]) if (length(grep(^[1-9], a))) return(as.integer(a)) } NA_integer_ } }
69 dim.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('dim', signature(x='BasicRaster'), function(x){ return(c(nrow(x), ncol(x), 1)) } ) setMethod('dim', signature(x='RasterStackBrick'), function(x){ return(c(nrow(x), ncol(x), nlayers(x))) } ) setMethod('nrow', signature(x='BasicRaster'), function(x){ return(x@nrows)} ) setMethod('ncol', signature(x='BasicRaster'), function(x){ return(x@ncols) } ) setMethod('dim<-', signature(x='BasicRaster'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x)) } value <- as.integer(pmax(round(value[1:2]), c(1,1))) x@nrows <- value[1] x@ncols <- value[2] return(x) } ) setMethod('dim<-', signature(x='RasterLayer'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x)) } else if (length(value) > 2) { value <- value[1:2] } value <- as.integer(pmax(round(value), c(1,1))) if (value[1] != nrow(x) | value[2] != ncol(x)) { x <- clearValues(x) x <- .clearFile(x) x@nrows <- value[1] x@ncols <- value[2] } return(x) } ) setMethod('dim<-', signature(x='RasterBrick'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x), nlayers(x)) } else if (length(value) == 2) { value <- c(value, nlayers(x)) } else if (length(value) > 3) { warning('value should have length 1, 2, or 3. Additional values ignored') value <- value[1:3] } value <- as.integer(pmax(round(value), c(1,1,1))) if (value[1] != nrow(x) | value[2] != ncol(x) | value[3] != nlayers(x)) { x <- clearValues(x) x <- .clearFile(x) x@nrows <- value[1] x@ncols <- value[2] x@data@nlayers <- value[3] } return(x) } )
70 direction.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : September 2009 # revised October 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric(direction)) { setGeneric(direction, function(x, ...) standardGeneric(direction)) } setMethod('direction', signature(x='RasterLayer'), function(x, filename='', degrees=FALSE, from=FALSE, doEdge=FALSE, ...) { out <- raster(x) if (couldBeLonLat(out)) { longlat=TRUE } else { longlat=FALSE } longlat <- as.integer(longlat) degrees <- as.integer(degrees) from <- as.integer(from) if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', asNA=TRUE, progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (class(pts) == try-error) { stop('This function has not yet been implemented for very large files') } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells (for which to compute a direction)') } filename <- trim(filename) if ( canProcessInMemory(out, 3)) { vals <- getValues(x) i <- which(is.na(vals)) xy <- xyFromCell(out, i) vals[] <- NA vals[i] <- .Call('directionToNearestPoint', xy, pts, longlat, degrees, from, PACKAGE='raster') out <- setValues(out, vals) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } out <- writeStart(out, filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='direction', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- NA if (length(j) > 0) { vals[j] <- .Call(directionToNearestPoint, xy[j, ,drop=FALSE], pts, longlat, degrees, from, PACKAGE='raster') } out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } )
71 disaggregate.R
# Author: Robert Hijmans # Date : October 2008 - December 2011 # Version 1.0 # Licence GPL v3 # April 2012: Several patches & improvements by Jim Regetz if (!isGeneric(disaggregate)) { setGeneric(disaggregate, function(x, ...) standardGeneric(disaggregate)) } setMethod('disaggregate', signature(x='Raster'), function(x, fact=NULL, method='', filename='', ...) { method <- tolower(method) if (!method %in% c('bilinear', '')) { stop('unknown method. Should be bilinear or ') } stopifnot(!is.null(fact)) fact <- as.integer(round(fact)) if (length(fact)==1) { if (fact == 1) return(x) if (fact < 2) { stop('fact should be >= 1') } xfact <- yfact <- fact } else if (length(fact)==2) { xfact <- fact[1] yfact <- fact[2] if (xfact < 1) { stop('fact[1] should be > 0') } if (yfact < 1) { stop('fact[2] should be > 0') } if (xfact == 1 & yfact == 1) { return(x) } } else { stop('length(fact) should be 1 or 2') } filename <- trim(filename) nl <- nlayers(x) if (nl > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } ncx <- ncol(x) nrx <- nrow(x) dim(out) <- c(nrx * yfact, ncx * xfact) names(out) <- names(x) if (! inherits(x, 'RasterStack')) { if (! inMemory(x) & ! fromDisk(x) ) { return(out) } } if (method=='bilinear') { return(resample(x, out, method='bilinear', filename=filename, ...)) } if (canProcessInMemory(out, 3)) { x <- getValues(x) cols <- rep(seq.int(ncx), each=xfact) rows <- rep(seq.int(nrx), each=yfact) cells <- as.vector( outer(cols, ncx*(rows-1), FUN=+) ) if (nl > 1) { x <- x[cells, ] } else { x <- x[cells] } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename=filename,...) } } else { tr <- blockSize(x, n=nlayers(x) * prod(fact)) rown <- (tr$row-1) * yfact + 1 pb <- pbCreate(tr$n, label='disaggregate', ...) if (is.null(list(...)$datatype)) { out <- writeStart(out, filename=filename, datatype=.commonDataType(dataType(x)), ...) } else { out <- writeStart(out, filename=filename, ...) } x <- readStart(x, ...) cols <- rep(seq.int(ncx), each=xfact) rows <- rep(seq.int(tr$nrows[1]), each=yfact) cells <- as.vector( outer(cols, ncx*(rows-1), FUN=+) ) for (i in 1:tr$n) { if (i == tr$n) { if (tr$nrows[i] != tr$nrows[1]) { rows <- rep(seq.int(tr$nrows[i]), each=yfact) cells <- outer(cols, ncx*(rows-1), FUN=+) } } v <- getValues(x, tr$row[i], tr$nrows[i]) if (nl > 1) { v <- v[cells, ] } else { v <- v[cells] } out <- writeValues(out, v, rown[i]) pbStep(pb, i) } out <- writeStop(out) x <- readStop(x) pbClose(pb) } return(out) } )
72 distanceFromPoints.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : September 2009 # Version 0.9 # Licence GPL v3 distanceFromPoints <- function(object, xy, filename='', ...) { pts <- .pointsToMatrix(xy) rm(xy) filename <- trim(filename) if (couldBeLonLat(object)) { longlat=TRUE } else { longlat=FALSE } out <- raster(object) if (canProcessInMemory(out, 4)) { xy <- xyFromCell(out, 1:ncell(out)) out <- setValues(out, .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster')) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster') out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) }
73 distance.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : September 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(distance)) { setGeneric(distance, function(x, ...) standardGeneric(distance)) } setMethod('distance', signature(x='RasterLayer'), function(x, filename='', doEdge=TRUE, ...) { if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (class(pts) == try-error) { return( .distanceRows(x, filename=filename, ...) ) } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells (for which to compute a distance)') } out <- raster(x) filename <- trim(filename) if (couldBeLonLat(x)) { longlat=TRUE } else { longlat=FALSE } if (canProcessInMemory(out, 6)) { pb <- pbCreate(3, label='distance', ...) x <- values(x) i <- which(is.na(x)) if (length(i) < 1) { stop('raster has no NA values to compute distance to') } pbStep(pb) x[] <- 0 xy <- xyFromCell(out, i) x[i] <- .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster') pbStep(pb) out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } pbStep(pb) pbClose(pb) return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='distance', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- 0 if (length(j) > 0) { vals[j] <- .Call(distanceToNearestPoint, xy[j,,drop=FALSE], pts, as.integer(longlat), PACKAGE='raster') } out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } )
74 distanceRows.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : September 2009 # Version 0.9 # Licence GPL v3 .distanceRows <- function(object, filename, progress='', ...) { filename <- trim(filename) overwrite <- .overwrite(...) if( (!overwrite) & file.exists(filename)) { stop('file exists; use overwrite=TRUE to overwrite it') } if (couldBeLonLat(object)) { longlat=TRUE } else { longlat=FALSE } e <- boundaries(object, classes=FALSE, type='inner', asNA=TRUE) r <- raster(object) tr <- blockSize(r, n=3) tmp = rasterTmpFile() extension(tmp) = '.tif' .requireRgdal() r <- writeStart(r, filename=tmp, format='GTiff') pb <- pbCreate(tr$n, progress=progress) xx <- xFromCol( r, 1:ncol(r) ) hasWritten=FALSE for (i in 1:tr$n) { # get the from points for a block v <- getValuesBlock(e, row=tr$row[i], nrows=tr$nrows[i]) x <- rep(xx, tr$nrows[i]) y <- yFromRow(r, tr$row[i]) - (0:(tr$nrows[i]-1)) * yres(r) y <- rep(y, each=ncol(r)) xyv <- cbind(x,y,v) from <- na.omit(xyv)[,1:2] if (isTRUE(nrow(from)==0)) { pbStep(pb, i) next } for (j in 1:tr$n) { # distance to these points for all blocks x <- rep(xx, tr$nrows[j]) y <- yFromRow(r, tr$row[j]) - (0:(tr$nrows[j]-1)) * yres(r) y <- rep(y, each=ncol(r)) v <- getValuesBlock(object, row=tr$row[j], nrows=tr$nrows[j]) xyv <- cbind(x,y,v) to <- xyv[is.na(xyv[,3]), 1:2] v[] = 0 if ( isTRUE(nrow(to) > 0) ) { v[is.na(xyv[,3])] <- .Call(distanceToNearestPoint, to, from, as.integer(longlat), PACKAGE='raster') } if (hasWritten) { # after the first round, compare new values with previously written values v <- pmin(v, .getTransientRows(r, tr$row[j], n=tr$nrows[j])) } r <- writeValues(r, v, tr$row[j]) } hasWritten = TRUE pbStep(pb, i) } r <- writeStop(r) pbClose(pb) r <- writeRaster(r, filename=filename, ...) return(r) }
75 dotdens.R
# Robert Hijmans # Based on maptools:dotsInPolys by Roger Bivand .dotdensity <- function(p, field, x=1, type=regular, seed=0,...) { set.seed(seed) stopifnot(inherits(p, 'SpatialPolygons')) n <- length(p) if (n < 1) return(invisible(NULL)) f <- tolower(type) stopifnot(type %in% c('regular', 'random')) if (inherits(p, 'SpatialPolygonsDataFrame')) { if (is.numeric(field)) { if (length(field)==1) { field <- round(field) stopifnot(field > 0 & field <= ncol(p)) field <- p@data[, field] } else { stopifnot(length(field)==length(p)) } } else if (is.character(field)) { stopifnot(field %in% names(p)) field <- p@data[, field] } } else { stopifnot(is.numeric(field)) stopifnot(length(field)==length(p)) } x <- x[1] stopifnot(x > 0) d <- round(field / x) d[d < 1] <- 0 d[is.na(d)] <- 0 res <- vector(mode = list, length = n) for (i in 1:n) { if (d[i] > 0) { ires <- try (spsample(p[i, ], d[i], type=f), silent=TRUE ) if (class(ires) == 'try-error') { print(paste('error, ', d[i])) ires <- NULL } if (!is.null(ires)) { res[[i]] <- cbind(coordinates(ires), id=i) } } } do.call(rbind, res) }
76 drawExtent.R
# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009, December 2011 # Version 1.0 # Licence GPL v3 drawExtent <- function(show=TRUE, col=red) { if (show) { loc1 <- locator(n=1, type=p, pch='+', col=col) } else { loc1 <- locator(n=1) } loc2 <- locator(n=1) loc <- rbind(unlist(loc1), unlist(loc2)) e <- extent(min(loc[,'x']), max(loc[,'x']), min(loc[,'y']), max(loc[,'y'])) if (e@xmin == e@xmax) { e@xmin <- e@xmin - 0.0000001 e@xmax <- e@xmax + 0.0000001 } if (e@ymin == e@ymax) { e@ymin <- e@ymin - 0.0000001 e@ymax <- e@ymax + 0.0000001 } if (show) { p <- rbind(c(e@xmin, e@ymin), c(e@xmin, e@ymax), c(e@xmax, e@ymax), c(e@xmax, e@ymin), c(e@xmin, e@ymin) ) lines(p, col=col) } return(e) }
77 drawPoly.R
# R function for the raster package # Author: Robert J. Hijmans # contact: r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 drawPoly <- function(sp=TRUE, col='red', lwd=2, ...) { xy <- locator(n=10000, type=l, col=col, lwd=lwd, ...) xy <- cbind(xy$x, xy$y) xy <- rbind(xy, xy[1,]) lines(xy[(length(xy[,1])-1):length(xy[,1]),], col=col, lwd=lwd, ...) if (sp) { return( SpatialPolygons(list(Polygons(list(Polygon(xy)), 1))) ) } else { return(xy) } } drawLine <- function(sp=TRUE, col='red', lwd=2, ...) { xy <- locator(n=10000, type=l, col=col, lwd=lwd, ...) xy <- cbind(xy$x, xy$y) if (sp) { return( SpatialLines(list(Lines(list(Line(xy)), 1))) ) } else { return(xy) } }
78 drivers.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : November 2008 # Version 0.9 # Licence GPL v3 .nativeDrivers <- function() { return( c(raster, SAGA, IDRISI, IDRISIold, BIL, BSQ, BIP) ) } .nativeDriversLong <- function() { return( c(R-raster, SAGA GIS, IDRISI, IDRISI (img/doc), Band by Line, Band Sequential, Band by Pixel) ) } .isNativeDriver <- function(d) { return( d %in% .nativeDrivers() ) } writeFormats <- function() { if ( .requireRgdal(FALSE) ) { gd <- .gdalWriteFormats() short <- c(.nativeDrivers(), 'ascii', 'CDF', 'big', as.vector(gd[,1])) long <- c(.nativeDriversLong(), 'Arc ASCII', 'NetCDF', 'big.matrix', as.vector(gd[,2])) } else { short <- c(.nativeDrivers(), 'ascii', 'CDF', 'big', ) long <- c(.nativeDriversLong(), Arc ASCII, NetCDF, big.matrix, , rgdal not installed) } m <- cbind(short, long) colnames(m) <- c(name, long_name) return(m) }
79 dropLayer.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(dropLayer)) { setGeneric(dropLayer, function(x, i, ...) standardGeneric(dropLayer)) } ...nameToIndex <- function(name, allnames) { # this is the same as match, I think k = NULL for (i in 1:length(name)) { k = c(k, which(allnames == name[i])[1]) } return(k) } setMethod('dropLayer', signature(x='RasterStack'), function(x, i, ...) { if (is.character(i)) { i = match(i, names(x)) } i <- sort(unique(round(i))) i <- i[i > 0 & i <= nlayers(x)] if (length(i) > 0) { x@layers <- x@layers[-i] } return(x) } ) setMethod('dropLayer', signature(x='RasterBrick'), function(x, i, ...) { if (is.character(i)) { i <- match(i, names(x)) } i <- sort(unique(round(i))) nl <- nlayers(x) i <- i[i > 0 & i <= nl] if (length(i) < 1) { return(x) } else { sel <- which(! 1:nl %in% i ) if (length(sel) == 0) { return(brick(x, values=FALSE)) } else { return(subset(x, sel, ...)) } } } )
80 erase.R
if (!isGeneric(erase)) { setGeneric(erase, function(x, y, ...) standardGeneric(erase)) } .gDif <- function(x, y) { xln <- length(x@polygons) yln <- length(y@polygons) if (xln==0 | yln==0) { return(x) } rn <- row.names(x) for (i in xln:1) { z <- x[i,] for (j in 1:yln) { z <- rgeos::gDifference(z, y[j,]) if (is.null(z)) { break } } if (is.null(z)) { x <- x[-i,] rn <- rn[-i] } else { x@polygons[i] <- z@polygons } } if (length(rn) > 0) { row.names(x) <- rn } x } setMethod(erase, signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ...){ require(rgeos) if (! identical(x@proj4string, y@proj4string) ) { warning('non identical CRS') y@proj4string <- x@proj4string } if (!.hasSlot(x, 'data')) { d <- data.frame(ID=1:length(x@polygons)) rownames(d) <- row.names(x) x <- SpatialPolygonsDataFrame(x, data=d) dropframe <- TRUE } else { dropframe <- FALSE } y <- aggregate(y) int <- rgeos::gIntersects(x, y, byid=TRUE) int1 <- apply(int, 2, any) int2 <- apply(int, 1, any) if (sum(int1) == 0) { # no intersections return(x) } if (all(int1)) { part1 <- NULL } else { part1 <- x[!int1,] } part2 <- .gDif(x[int1,], y[int2,]) part2 <- SpatialPolygonsDataFrame(part2, x@data[match(row.names(part2), rownames(x@data)), ,drop=FALSE]) if (!is.null(part1)) { part2 <- rbind(part1, part2) } if (length(part2@polygons) > 1) { part2 <- aggregate(part2, v=colnames(part2@data)) } if (dropframe) { return( as(part2, 'SpatialPolygons') ) } else { return( part2 ) } } )
81 extend.R
# Author: Robert J. Hijmans # Date : October 2008 # Licence GPL v3 # revised November 2011 # version 1.0 if (!isGeneric(extend)) { setGeneric(extend, function(x, y, ...) standardGeneric(extend)) } setMethod('extend', signature(x='Extent'), # function by Etienne B. Racine function(x, y, ...) { if (length(y) == 1) { y <- rep(y, 4) } else if (length(y) == 2) { y <- rep(y, each=2) } else if (! length(y) == 4 ) { stop('argument y should be a vector of 1, 2, or 4 elements') } x@xmin <- x@xmin - y[1] x@xmax <- x@xmax + y[2] x@ymin <- x@ymin - y[3] x@ymax <- x@ymax + y[4] validObject(x) x } ) setMethod('extend', signature(x='Raster'), function(x, y, value=NA, filename='', ...) { if (is.vector(y)) { if (length(y) <= 2) { adj <- abs(y) * rev(res(x)) y <- extent(x) y@ymin <- y@ymin - adj[1] y@ymax <- y@ymax + adj[1] y@xmin <- y@xmin - adj[2] y@xmax <- y@xmax + adj[2] } } test <- try ( y <- extent(y), silent=TRUE ) if (class(test) == try-error) { stop('Cannot get an Extent object from argument y') } filename <- trim(filename) y <- alignExtent(y, x) # only expanding here, not cropping y <- union(y, extent(x)) if (nlayers(x) <= 1) { out <- raster(x) leg <- x@legend } else { out <- brick(x, values=FALSE) leg <- new('.RasterLegend') } out@data@names <- names(x) out <- setExtent(out, y, keepres=TRUE) if (is.factor(x)) { # if (is.na(value)) { levels(out) <- levels(x) # } } if (nrow(x) == nrow(out) & ncol(x) == ncol(out)) { # nothing to do. return(x) } if (! hasValues(x) ) { return(out) } dtp <- FALSE datatype <- list(...)$datatype if (is.null(datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } dtp <- TRUE } if (canProcessInMemory(out)) { d <- matrix(value, nrow=ncell(out), ncol=nlayers(x)) d[cellsFromExtent(out, extent(x)), ] <- getValues(x) x <- setValues(out, d) if (filename != '') { if (dtp) { x <- writeRaster(x, filename=filename, datatype=datatype, ...) } else { x <- writeRaster(x, filename=filename, ...) } } return(x) } else { startrow <- rowFromY(out, yFromRow(x, 1)) endrow <- rowFromY(out, yFromRow(x, nrow(x))) startcol <- colFromX(out, xFromCol(x, 1)) endcol <- colFromX(out, xFromCol(x, ncol(x))) tr <- blockSize(out) tr$row <- sort(unique(c(tr$row, startrow, endrow+1))) tr$nrows <- c(tr$row[-1], nrow(out)+1) - tr$row tr$n <- length(tr$row) pb <- pbCreate(tr$n, label='extend', ...) if (dtp) { out <- writeStart(out, filename=filename, datatype=datatype, ... ) } else { out <- writeStart(out, filename=filename, ... ) } for (i in 1:tr$n) { d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out)) if (tr$row[i] <= endrow & (tr$row[i]+tr$nrows[i]-1) >= startrow) { cells <- startcol:endcol + rep((0:(tr$nrows[i]-1)) * ncol(out), each=endcol-startcol+1) d[cells, ] <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i]) } out <- writeValues(out, d, tr$row[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) return(out) } } )
82 extension.R
# return or change file extensions # Author: Robert J. Hijmans # Date : October 2008 # Version 1.0 # Licence GPL v3 extension <- function(filename, value=NULL, maxchar=10) { if (!is.null(value)) { extension(filename) <- value return(filename) } lfn <- nchar(filename) ext <- list() for (f in 1:length(filename)) { extstart <- -1 for (i in lfn[f] : 2) { if (substr(filename[f], i, i) == .) { extstart <- i break } } if (extstart > 0) { ext[f] <- substr(filename[f], extstart, lfn[f]) } else { ext[f] <- } } ext <- unlist(ext) ext[nchar(ext) > maxchar] <- '' return(ext) } 'extension<-' <- function(filename, value) { value <- trim(value) if (value != & substr(value, 1, 1) != .) { value <- paste(., value, sep=) } lfn <- nchar(filename) fname <- list() for (f in 1:length(filename)) { extstart <- -1 for (i in lfn[f] : 2) { if (substr(filename[f], i, i) == .) { extstart <- i break } } if (extstart > 0 & (lfn[f] - extstart) < 8) { fname[f] <- paste(substr(filename[f], 1, extstart-1), value, sep=) } else { fname[f] <- paste(filename[f], value, sep=) } } return( unlist(fname) ) } .getExtension <- function(f, format) { if (.setfileext()) { def <- .defaultExtension(format) if (def != '') { extension(f) <- def } } return(f) } .defaultExtension <- function(format=.filetype()) { format <- toupper(format) if (format == 'RASTER') { return('.grd') } else if (format == 'GTIFF') { return('.tif') } else if (format == 'CDF') { return('.nc') } else if (format == 'KML') { return('.kml') } else if (format == 'KMZ') { return('.kmz') } else if (format == 'BIG.MATRIX') { return('.big') } else if (format == 'BIL') { return('.bil') } else if (format == 'BSQ') { return('.bsq') } else if (format == 'BIP') { return('.bip') } else if (format == 'ASCII') { return('.asc') } else if (format == 'RST') { return('.rst') } else if (format == 'ILWIS') { return('.mpr') } else if (format == 'SAGA') { return('.sdat') } else if (format == 'BMP') { return('.bmp') } else if (format == 'ADRG') { return('.gen') } else if (format == 'BT') { return('.bt') } else if (format == 'EHdr') { return('.bil') } else if (format == 'ENVI') { return('.envi') } else if (format == 'ERS') { return('.ers') } else if (format == 'GSBG') { return('.grd') } else if (format == 'HFA') { return( '.img') } else if (format == 'IDA') { return( '.img') } else if (format == 'RMF') { return('.rsw') } else { return('') } }
83 extent.R
# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(extent)) { setGeneric(extent, function(x, ...) standardGeneric(extent)) } setMethod('extent', signature(x='Extent'), function(x){ return(x) } ) setMethod('extent', signature(x='BasicRaster'), function(x, r1, r2, c1, c2){ e <- x@extent r <- res(x) if (! missing(c1) ) { xn <- xFromCol(x, c1) - 0.5 * r[1] if (is.na(xn)) { warning('invalid first colummn') xn <- e@xmin } } else { xn <- e@xmin } if (! missing(c2) ) { xx <- xFromCol(x, c2) + 0.5 * r[1] if (is.na(xx)) { warning('invalid second colummn') xx <- e@xmax } } else { xx <- e@xmax } if (! missing(r1) ) { yx <- yFromRow(x, r1) + 0.5 * r[2] if (is.na(yx)) { warning('invalid first row') yx <- e@ymax } } else { yx <- e@ymax } if (! missing(r2) ) { yn <- yFromRow(x, r2) - 0.5 * r[2] if (is.na(yn)) { warning('invalid second row') yn <- e@ymin } } else { yn <- e@ymin } if (xn == xx) { stop('min and max x are the same') } if (yn == yx) { stop('min and max y are the same') } if (xn > xx) { warning('min x larger than max x') } if (yn > yx) { warning('min y larger than max y') } e <- extent(sort(c(xn, xx)), sort(c(yn, yx))) if (validObject(e)) { return(e) } } ) setMethod('extent', signature(x='Spatial'), function(x){ bndbox <- bbox(x) e <- new('Extent') e@xmin <- bndbox[1,1] e@xmax <- bndbox[1,2] e@ymin <- bndbox[2,1] e@ymax <- bndbox[2,2] return(e) } ) setMethod('extent', signature(x='matrix'), function(x){ d <- dim(x) if (min(d) < 2) { stop('matrix should have dimensions of at least 2 by 2') } if (d[2] > 2) { stop('matrix should not have more than 2 columns') } e <- new('Extent') if (nrow(x) == 2) { # assuming a 'sp' bbox object e@xmin <- min(x[1,]) e@xmax <- max(x[1,]) e@ymin <- min(x[2,]) e@ymax <- max(x[2,]) } else { a <- as.vector(apply(x, 2, range, na.rm=TRUE)) e@xmin <- a[1] e@xmax <- a[2] e@ymin <- a[3] e@ymax <- a[4] } return(e) } ) setMethod('extent', signature(x='numeric'), function(x, ...){ dots <- unlist(list(...)) x <- c(x, dots) if (length(x) < 4) { stop('insufficient number of elements (should be 4)') } if (length(x) > 4) { warning('more elements than expected (should be 4)') } names(x) <- NULL e <- new('Extent') e@xmin <- x[1] e@xmax <- x[2] e@ymin <- x[3] e@ymax <- x[4] return(e) } ) # contributed by Etienne Racine setMethod('extent', signature(x='list'), function(x, ...) { stopifnot(c(x, y) %in% names(x)) stopifnot(lapply(x[c(x, y)], length) >= 2) lim <- c(range(x$x), (range(x$y))) return(extent(lim,...)) } ) setMethod('extent', signature(x='GridTopology'), # contributed by Michael Sumner function(x){ cco <- x@cellcentre.offset cs <- x@cellsize cdim <- x@cells.dim e <- new('Extent') e@xmin <- cco[1] - cs[1]/2 e@xmax <- e@xmin + cs[1] * cdim[1] e@ymin <- cco[2] - cs[2]/2 e@ymax <- e@ymin + cs[2] * cdim[2] return(e) } )
84 extentUnion.R
# Authors: Robert J. Hijmans # contact: r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3
85 extractExtent.R
# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='Extent'), function(x, y, cellnumbers=FALSE, fun=NULL, na.rm=FALSE, layer=1, nl, df=FALSE, ...) { e <- intersect(extent(x), y) e <- alignExtent(e, x) if (!is.null(fun)) { cellnumbers <- FALSE } else if (cellnumbers) { cell <- cellsFromExtent(x, e) value <- extract(x, cell, layer=layer, nl=nl, df=df) if (df) { value <- data.frame(cell=cell, value) } else { value <- cbind(cell=cell, value) } return(value) } r <- res(x) e@xmin <- e@xmin + 0.25 * r[1] e@xmax <- e@xmax - 0.25 * r[1] e@ymin <- e@ymin + 0.25 * r[2] e@ymax <- e@ymax - 0.25 * r[2] row <- rowFromY(x, e@ymax) lastrow <- rowFromY(x, e@ymin) nrows <- lastrow-row+1 col <- colFromX(x, e@xmin) lastcol <- colFromX(x, e@xmax) ncols <- lastcol-col+1 v <- getValuesBlock(x, row, nrows, col, ncols) if (nlayers(x) > 1) { if (missing(layer)) { layer <- 1 } else { layer <- max(min(nlayers(x), layer), 1) } if (missing(nl)) { nl <- nlayers(x) - layer + 1 } else { nl <- max(min(nlayers(x)-layer+1, nl), 1) } lyrs <- layer:(layer+nl-1) v <- v[ , lyrs, drop=FALSE] } else { lyrs <- 1 } if (! is.null(fun)) { if (is.matrix(v)) { ln <- colnames(v) v <- apply(v, 2, FUN=fun, na.rm=na.rm) names(v) <- ln } else { v <- fun(v, na.rm=na.rm) } } if (df) { v <- data.frame(v) if (ncol(v) == 1) { v <- data.frame(factorValues(x, v, lyrs)) } else { v <- .insertFacts(x, v, lyrs) } } return(v) } )
86 extractLines.R
# Author: Robert J. Hijmans # Date : December 2009 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='SpatialLines'), function(x, y, fun=NULL, na.rm=FALSE, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, along=FALSE, sp=FALSE, ...){ px <- projection(x, asText=FALSE) comp <- compareCRS(px, projection(y), unknown=TRUE) if (!comp) { .requireRgdal() warning('Transforming SpatialLines to the CRS of the Raster object') y <- spTransform(y, px) } if (missing(layer)) { layer <- 1 } if (missing(nl)) { nl <- nlayers(x) } if (!is.null(fun)) { cellnumbers <- FALSE along <- FALSE if (sp) { df <- TRUE } } else { if (sp) { sp <- FALSE warning('argument sp=TRUE is ignored if fun=NULL') } } if (along) { return(.extractLinesAlong(x, y, cellnumbers=cellnumbers, df=df, layer, nl, factors=factors, ...)) } spbb <- bbox(y) rsbb <- bbox(x) addres <- 2 * max(res(x)) nlns <- length( y@lines ) res <- list() res[[nlns+1]] <- NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { if (df) { res <- matrix(ncol=1, nrow=0) colnames(res) <- 'ID' return(res) } else { return(res[1:nlns]) } } rr <- raster(x) cn <- names(x) pb <- pbCreate(nlns, label='extract', ...) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nlns, length(cl)) cat('Using cluster with', nodes, 'nodes\n') flush.console() snow::clusterExport(cl, c('rsbb', 'rr', 'addres', 'cellnumbers'), envir=environment()) clFun <- function(i, pp) { spbb <- bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # always TRUE? r <- .xyValues(x, xy, layer=layer, nl=nl) if (cellnumbers) { r <- cbind(cellFromXY(rr, xy), r) colnames(r) <- c('cell', cn) } } else { r <- NULL } } r } for (ni in 1:nodes) { snow::sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni) } for (i in 1:nlns) { d <- snow::recvOneData(cl) if (! d$value$success) { stop('cluster error at polygon: ', i) } res[[d$value$tag]] <- d$value$value ni <- ni + 1 if (ni <= nlns) { snow::sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni) } pbStep(pb) } } else { for (i in 1:nlns) { pp <- y[i,] spbb <- bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (cellnumbers) { v <- cbind(cellFromXY(rr, xy), .xyValues(x, xy, layer=layer, nl=nl)) colnames(v) <- c('cell', cn) res[[i]] <- v } else { res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl) } } pbStep(pb) } } res <- res[1:nlns] pbClose(pb) if (! is.null(fun)) { i <- sapply(res, is.null) if (nlayers(x) > 1) { j <- matrix(ncol=nlayers(x), nrow=length(res)) j[!i] <- t(sapply(res[!i], function(x) apply(x, 2, fun, na.rm=na.rm))) colnames(j) <- names(x) } else { j <- vector(length=length(i)) j[i] <- NA j[!i] <- sapply(res[!i], fun, na.rm=na.rm) } res <- j } if (df) { if (!is.list(res)) { res <- data.frame(ID=1:NROW(res), res) } else { res <- data.frame( do.call(rbind, sapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) } lyrs <- layer:(layer+nl-1) colnames(res) <- c('ID', names(x)[lyrs]) if (any(is.factor(x)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } if (sp) { if (nrow(res) != nlns) { warning('sp=TRUE is ignored because fun does not summarize the values of each line to a single number') return(res) } if (! .hasSlot(y, 'data') ) { y <- SpatialLinesDataFrame(y, res[, -1, drop=FALSE]) } else { y@data <- cbind(y@data, res[, -1, drop=FALSE]) } return(y) } res } ) .extractLinesAlong <- function(x, y, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, ...){ spbb <- bbox(y) rsbb <- bbox(x) addres <- 2 * max(res(x)) nlns <- length( y@lines ) res <- list() res[[nlns+1]] <- NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { if (df) { res <- matrix(ncol=1, nrow=0) colnames(res) <- 'ID' return(res) } else { return(res[1:nlns]) } } rr <- raster(x) cn <- names(x) pb <- pbCreate(nlns, label='extract', ...) y <- as.data.frame(y, xy=TRUE) for (i in 1:nlns) { yp <- y[y$object == i, ] nparts <- max(yp$part) vv <- NULL for (j in 1:nparts) { pp <- yp[yp$part==j, c('x', 'y'), ] for (k in 1:(nrow(pp)-1)) { ppp <- pp[k:(k+1), ] spbb <- bbox(as.matrix(ppp)) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { lns <- SpatialLines(list(Lines(list(Line(ppp)), 1))) rc <- crop(rr, extent(lns) + addres) rc <- .linesToRaster(lns, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] v <- cbind(row=rowFromY(rr, xy[,2]), col=colFromX(rr, xy[,1]), .xyValues(x, xy, layer=layer, nl=nl)) #up or down? updown <- c(1,-1)[(ppp[1,2] < ppp[2,2]) + 1] rightleft <- c(-1,1)[(ppp[1,1] < ppp[2,1]) + 1] v <- v[order(updown*v[,1], rightleft*v[,2]), ] #up <- ppp[1,2] < ppp[2,2] #right <- ppp[1,1] < ppp[2,1] # if (up) { # if (right) { # v <- v[order(-v[,1], v[,2]), ] # } else { # v <- v[order(-v[,1], -v[,2]), ] # } # } else { # if (!right) { # v <- v[order(v[,1], -v[,2]), ] # } # } vv <- rbind(vv, v) } } if (cellnumbers) { vv <- cbind(cellFromRowCol(rr, vv[,1], vv[,2]), vv[,-c(1:2)]) colnames(vv) <- c('cell', names(x)) } else { vv <- vv[,-c(1:2)] if (NCOL(vv) > 1) { colnames(vv) <- names(x) } } res[[i]] <- vv pbStep(pb) } } res <- res[1:nlns] pbClose(pb) if (df) { res <- data.frame( do.call(rbind, sapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) lyrs <- layer:(layer+nl-1) colnames(res) <- c('ID', names(x)[lyrs]) if (any(is.factor(x)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } res }
87 extractPoints.R
# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='matrix'), function(x, y, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, ...){ .xyValues(x, y, method=method, buffer=buffer, small=small, cellnumbers=cellnumbers, fun=fun, na.rm=na.rm, layer=layer, nl=nl, df=df, factors=factors, ...) }) setMethod('extract', signature(x='Raster', y='data.frame'), function(x, y, ...){ return( .xyValues(x, as.matrix(y), ...)) }) setMethod('extract', signature(x='SpatialPolygons', y='SpatialPoints'), function(x, y, ...){ stopifnot(require(rgeos)) if (! identical(proj4string(x), proj4string(y)) ) { warning('non identical CRS') y@proj4string <- x@proj4string } i <- rgeos::gIntersects(y, x, byid=TRUE) j <- cbind(1:length(y), rep(1:length(x), each=length(y)), as.vector(t(i))) j <- j[j[,3] == 1, -3] colnames(j) <- c('point.ID', 'poly.ID') if (.hasSlot(x, 'data')) { r <- data.frame(j, x@data[j[,2], ,drop=FALSE], row.names=NULL) } else { r <- data.frame(j, row.names=NULL) } q <- data.frame(point.ID = 1:length(y)) merge(q, r, by='point.ID', all=TRUE) }) setMethod('extract', signature(x='Raster', y='SpatialPoints'), function(x, y, ..., df=FALSE, sp=FALSE){ px <- projection(x, asText=FALSE) comp <- compareCRS(px, projection(y), unknown=TRUE) if (!comp) { if (!.requireRgdal()) { warning('CRS of SpatialPoints and rater do not match') } else { warning('Transforming SpatialPoints to the CRS of the Raster') y <- spTransform(y, px) } } if (sp) { v <- .xyValues(x, coordinates(y), ..., df=TRUE) if (!.hasSlot(y, 'data')) { y <- SpatialPointsDataFrame(y, v[, -1, drop=FALSE]) } else { y@data <- cbind(y@data, v[, -1, drop=FALSE]) } return(y) } else { .xyValues(x, coordinates(y), ..., df=df) } }) .xyValues <- function(object, xy, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, sp=FALSE, ...) { nlyrs <- nlayers(object) if (nlyrs > 1) { if (missing(layer)) { layer <- 1 } if (missing(nl)) { nl <- nlyrs } layer <- min(max(1, round(layer)), nlyrs) nl <- min(max(1, round(nl)), nlyrs-layer+1) } else { layer <- 1 nl <- 1 } if (dim(xy)[2] != 2) { stop('xy should have 2 columns only.\nFound these dimensions: ', paste(dim(xy), collapse=', ') ) } if (! is.null(buffer)) { if (method != 'simple') { warning('method argument is ignored when a buffer is used') } res <- .xyvBuf(object, xy, buffer, fun, na.rm, layer=layer, nl=nl, cellnumbers=cellnumbers, small=small) } else if (method == 'bilinear') { res <- .bilinearValue(object, xy, layer=layer, n=nl) if (cellnumbers) { warning('cellnumbers' does not apply for bilinear values) } } else if (method=='simple') { cells <- cellFromXY(object, xy) res <- .cellValues(object, cells, layer=layer, nl=nl) if (cellnumbers) { res <- cbind(cells, res) if (ncol(res) == 2) { colnames(res)[2] <- names(object)[layer] } } } else { stop('invalid method argument. Should be simple or bilinear.') } if (df) { if (is.list(res)) { res <- lapply(1:length(res), function(x) if (length(res[[x]]) > 0) cbind(ID=x, res[[x]])) res <- do.call(rbind, res) rownames(res) <- NULL } else { res <- data.frame(cbind(ID=1:NROW(res), res)) } lyrs <- layer:(layer-1+nl) colnames(res) <- c('ID', names(object)[lyrs]) if (any(is.factor(object)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(object, v[,1], layer)) } else { v <- .insertFacts(object, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } res }
88 extractPolygons.R
# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='SpatialPolygons'), function(x, y, fun=NULL, na.rm=FALSE, weights=FALSE, cellnumbers=FALSE, small=TRUE, df=FALSE, layer, nl, factors=FALSE, sp=FALSE, ...){ px <- projection(x, asText=FALSE) comp <- compareCRS(px, projection(y), unknown=TRUE) if (!comp) { .requireRgdal() warning('Transforming SpatialPolygons to the CRS of the Raster') y <- spTransform(y, px) } spbb <- bbox(y) rsbb <- bbox(x) addres <- max(res(x)) npol <- length(y@polygons) res <- list() res[[npol+1]] <- NA if (!is.null(fun)) { cellnumbers <- FALSE if (weights) { if (!is.null(fun)) { test <- try(slot(fun, 'generic') == 'mean', silent=TRUE) if (!isTRUE(test)) { warning('fun was changed to mean; other functions cannot be used when weights=TRUE' ) } } fun <- function(x, ...) { # some complexity here because different layers could # have different NA cells if ( is.null(x) ) { return(rep(NA, nl)) } w <- x[,nl+1] x <- x[,-(nl+1), drop=FALSE] x <- x * w w <- matrix(rep(w, nl), ncol=nl) w[is.na(x)] <- NA w <- colSums(w, na.rm=TRUE) x <- apply(x, 1, function(X) { X / w } ) if (!is.null(dim(x))) { rowSums(x, na.rm=na.rm) } else { sum(x, na.rm=na.rm) } } } if (sp) { df <- TRUE } doFun <- TRUE } else { if (sp) { sp <- FALSE df <- FALSE warning('argument sp=TRUE is ignored if fun=NULL') } else if (df) { df <- FALSE warning('argument df=TRUE is ignored if fun=NULL') } doFun <- FALSE } if (missing(layer)) { layer <- 1 } else { layer <- max(min(nlayers(x), layer), 1) } if (missing(nl)) { nl <- nlayers(x) - layer + 1 } else { nl <- max(min(nlayers(x)-layer+1, nl), 1) } if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { if (df) { res <- data.frame(matrix(ncol=1, nrow=0)) colnames(res) <- 'ID' return(res) } return(res[1:npol]) } rr <- raster(x) pb <- pbCreate(npol, label='extract', ...) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(npol, length(cl)) cat('Using cluster with', nodes, 'nodes\n') flush.console() snow::clusterExport(cl, c('rsbb', 'rr', 'weights', 'addres', 'cellnumbers', 'small'), envir=environment()) clFun <- function(i, pp) { spbb <- bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE) rc[rc==0] <- NA xy <- rasterToPoints(rc) weight <- xy[,3] / sum(xy[,3]) xy <- xy[, -3, drop=FALSE] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch very small polygons r <- .xyValues(x, xy, layer=layer, nl=nl) if (weights) { if (cellnumbers) { cell <- cellFromXY(x, xy) r <- cbind(cell, r, weight) } else { r <- cbind(r, weight) } } else if (cellnumbers) { cell <- cellFromXY(x, xy) r <- cbind(cell, r) } } else { if (small) { ppp <- pp@polygons[[1]]@Polygons ishole <- sapply(ppp, function(z)z@hole) xy <- lapply(ppp, function(z)z@coords) xy <- xy[!ishole] if (length(xy) > 0) { cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z)))) value <- .cellValues(x, cell, layer=layer, nl=nl) if (weights) { weight=rep(1/NROW(value), NROW(value)) if (cellnumbers) { r <- cbind(cell, value, weight) } else { r <- cbind(value, weight) } } else if (cellnumbers) { r <- cbind(cell, value) } else { r <- value } } else { r <- NULL } } else { r <- NULL } } } r } for (ni in 1:nodes) { snow::sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni) } for (i in 1:npol) { d <- snow::recvOneData(cl) if (! d$value$success) { stop('cluster error at polygon: ', i) } if (doFun) { if (!is.null(d$value$value)) { if (nl > 1 & !weights) { res[[i]] <- apply(d$value$value, 2, fun, na.rm=na.rm) } else { res[[d$value$tag]] <- fun(d$value$value) } } } else { res[[d$value$tag]] <- d$value$value } ni <- ni + 1 if (ni <= npol) { snow::sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni) } pbStep(pb, i) } } else { for (i in 1:npol) { pp <- y[i,] spbb <- bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE) rc[rc==0] <- NA xy <- rasterToPoints(rc) weight <- xy[,3] / sum(xy[,3]) xy <- xy[,-3,drop=FALSE] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch holes or very small polygons if (weights) { value <- .xyValues(x, xy, layer=layer, nl=nl) if (cellnumbers) { cell <- cellFromXY(x, xy) res[[i]] <- cbind(cell, value, weight) } else { res[[i]] <- cbind(value, weight) } } else if (cellnumbers) { value <- .xyValues(x, xy, layer=layer, nl=nl) cell <- cellFromXY(x, xy) res[[i]] <- cbind(cell, value) } else { res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl) } } else if (small) { ppp <- pp@polygons[[1]]@Polygons ishole <- sapply(ppp, function(z)z@hole) xy <- lapply(ppp, function(z)z@coords) xy <- xy[!ishole] if (length(xy) > 0) { cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z)))) value <- .cellValues(x, cell, layer=layer, nl=nl) if (weights) { weight=rep(1/NROW(value), NROW(value)) if (cellnumbers) { res[[i]] <- cbind(cell, value, weight) } else { res[[i]] <- cbind(value, weight) } } else if (cellnumbers) { res[[i]] <- cbind(cell, value) } else { res[[i]] <- value } } # else do nothing; res[[i]] <- NULL } if (doFun) { if (!is.null(res[[i]])) { if (nl > 1 & !weights) { res[[i]] <- apply(res[[i]], 2, fun, na.rm=na.rm) } else { res[[i]] <- fun(res[[i]]) } } } } pbStep(pb) } } res <- res[1:npol] pbClose(pb) if (! is.null(fun)) { # try to simplify i <- sapply(res, length) if (length(unique(i[i != 0])) == 1) { if (any(i == 0)) { lng <- length(res) v <- do.call(rbind, res) res <- matrix(NA, nrow=lng, ncol=ncol(v)) res[which(i > 0), ] <- v } else { res <- do.call(rbind, res) } } else { if (sp) { warning('cannot return a sp object because the data length varies between polygons') sp <- FALSE df <- FALSE } else if (df) { warning('cannot return a data.frame because the data length varies between polygons') df <- FALSE } } } if (df) { if (!is.list(res)) { res <- data.frame(ID=1:NROW(res), res) } else { res <- data.frame( do.call(rbind, lapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) } lyrs <- layer:(layer+nl-1) if (cellnumbers) { nms <- c('ID', 'cell', names(x)[lyrs]) } else { nms <- c('ID', names(x)[lyrs]) } if (weights & is.null(fun)) { nms <- c(nms, 'weight') } colnames(res) <- nms if (any(is.factor(x)) & factors) { i <- ifelse(cellnumbers, 1:2, 1) v <- res[, -i, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,i,drop=FALSE], v) } } if (sp) { if (nrow(res) != npol) { warning('sp=TRUE is ignored because fun does not summarize the values of each polygon to a single number') return(res) } if (! .hasSlot(y, 'data') ) { y <- SpatialPolygonsDataFrame(y, res[, -1, drop=FALSE]) } else { y@data <- cbind(y@data, res[, -1, drop=FALSE]) } return(y) } res } )
89 extract.R
# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 if (!isGeneric(extract)) { setGeneric(extract, function(x, y, ...) standardGeneric(extract)) } setMethod('extract', signature(x='Raster', y='vector'), function(x, y, ...){ y <- round(y) return( .cellValues(x, y, ...) ) })
90 factor.R
# Author: Robert J. Hijmans # Date : February 2010 / June 2012 # Version 1.0 # Licence GPL v3 factorValues <- function(x, v, layer=1, att=NULL, append.names=FALSE) { stopifnot(is.factor(x)[layer]) rat <- levels(x)[[layer]] if (!is.data.frame(rat)) { rat <- rat[[1]] } # if (colnames(rat)[2]=='WEIGHT') { # i <- which(match(rat$ID, round(v))==1) # } else { i <- match(round(v), rat$ID) # } r <- rat[i, -1, drop=FALSE] rownames(r) <- NULL if (!is.null(att)) { if (is.character(att)) { att <- na.omit(match(att, colnames(r))) if (length(att) == 0) { warning(att does not includes valid names) } else { r <- r[, att, drop=FALSE] } } else { r <- r[, att, drop=FALSE] } } if (append.names) { colnames(r) <- paste(names(x)[layer], colnames(r), sep=_) } r } .insertFacts <- function(x, v, lyrs) { facts <- is.factor(x)[lyrs] if (!any(facts)) { return(v) } i <- which(facts) v <- sapply(1:length(facts), function(i) { if (facts[i]) { data.frame(factorValues(x, v[, i], i, append.names=TRUE)) } else { v[, i, drop=FALSE] } } ) do.call(data.frame, v) } if (!isGeneric(is.factor)) { setGeneric(is.factor, function(x) standardGeneric(is.factor)) } setMethod('is.factor', signature(x='Raster'), function(x) { f <- x@data@isfactor nl <- nlayers(x) if (length(f) < nl) { f <- c(f, rep(FALSE, nl))[1:nl] } f } ) setMethod('is.factor', signature(x='RasterStack'), function(x) { sapply(x@layers, function(x) x@data@isfactor) } ) if (!isGeneric(levels)) { setGeneric(levels, function(x) standardGeneric(levels)) } setMethod('levels', signature(x='Raster'), function(x) { f <- is.factor(x) if (any(f)) { if (inherits(x, 'RasterStack')) { return( sapply(x@layers, function(i) i@data@attributes) ) } else { return(x@data@attributes) } } else { return(NULL) } } ) .checkLevels <- function(old, newv) { if (! is.data.frame(newv)) { stop('new raster attributes (factor values) should be in a data.frame (inside a list)') } if (! ncol(newv) > 0) { stop('the number of columns in the raster attributes (factors) data.frame should be > 0') } if (! colnames(newv)[1] == c('ID')) { stop('the first column name of the raster attributes (factors) data.frame should be ID') } if (!is.null(old)) { # if (colnames(newv)[2] == 'WEIGHT') { # if (nrow(newv) < nrow(old)) { # warning('the number of rows in the raster attributes (factors) data.frame is lower than expected (values missing?)') # } # if (! all(unique(sort(newv[,1])) == sort(unique(old[,1])))) { # warning('the values in the ID column in the raster attributes (factors) data.frame have changed') # } # } else { if (! nrow(newv) == nrow(old)) { warning('the number of rows in the raster attributes (factors) data.frame is unexpected') } if (! all(sort(newv[,1]) == sort(old[,1]))) { warning('the values in the ID column in the raster attributes (factors) data.frame have changed') } # } } newv[, 1] <- as.integer(newv[, 1]) # if (colnames(newv)[2] == 'WEIGHT') { # newv[, 2] <- as.numeric(newv[, 2]) # } newv } setMethod('levels<-', signature(x='Raster'), function(x, value) { isfact <- is.factor(x) if (inherits(x, 'RasterLayer')) { if (!is.data.frame(value)) { if (is.list(value)) { value <- value[[1]] } } value <- .checkLevels(levels(x)[[1]], value) x@data@attributes <- list(value) x@data@isfactor <- TRUE return(x) } i <- ! sapply(value, is.null) if ( any(i) ) { stopifnot (length(value) == nlayers(x)) levs <- levels(x) for (j in which(i)) { value[[j]] <- .checkLevels(levs[[j]], value[[j]]) } x@data@attributes <- value x@data@isfactor <- i } else { x@data@attributes <- list() } x@data@isfactor <- i return(x) } ) if (!isGeneric(as.factor)) { setGeneric(as.factor, function(x) standardGeneric(as.factor)) } setMethod('as.factor', signature(x='RasterLayer'), function(x) { ratify(x) } ) if (!isGeneric(asFactor)) { setGeneric(asFactor, function(x, ...) standardGeneric(asFactor)) } setMethod('asFactor', signature(x='RasterLayer'), function(x, value=NULL, ...) { #warning(please use as.factor) x@data@isfactor <- TRUE if (is.null(value) ) { #x <- round(x) #this makes slot isfactor FALSE again x@data@attributes <- list(data.frame(VALUE=unique(x))) } else { x@data@attributes <- value } return(x) } )
91 filler.R
.filler <- function(x, y, maxv=12, circular=FALSE) { # should rewrite this using apply (or C) fill <- function(x, y) { r <- matrix(NA, nrow=length(x), ncol=maxv) if (circular) { for (i in 1:nrow(r)) { if (!is.na(y[i])) { if (x[i] < y[i]) { r[i, x[i]:y[i]] <- 1 } else { r[i, c(x[i]:maxv, 1:y[i])] <- 1 } } } r } else { for (i in 1:nrow(r)) { if (!is.na(y[i])) { r[i, x[i]:y[i]] <- 1 } } r } } x <- overlay(x, y, fun=fill) names(x) = paste('v', 1:maxv, sep='') x }
92 fixDBFnames.R
.fixDBFNames <- function(x, verbose=TRUE) { n <- gsub('^[[:space:]]+', '', gsub('[[:space:]]+$', '', x) ) nn <- n n <- gsub('[^[:alnum:]]', '_', n) n[nchar(n) > 10] <- gsub('_', '', n[nchar(n) > 10]) n[n==''] <- 'field' n <- gsub('^[^[:alpha:]]', 'X', n) n <- substr(n, 1, 10) # duplicate names nn <- as.matrix(table(n)) i <- which(nn > 1) if (! is.null(i)) { names <- rownames(nn)[i] n[n %in% names] <- substr(n[n %in% names], 1, 9) n <- make.unique(n, sep = ) } if (verbose) { i <- x == n if (! all(i)) { x <- rbind(x, n) colnames(x) <- paste('col_', 1:ncol(x), sep=) x <- x[, !i, drop=FALSE] rownames(x) = c('original name', 'adjusted name') print(x) } } return(n) }
93 flip.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(flip)) { setGeneric(flip, function(x, direction, ...) standardGeneric(flip)) } setMethod('flip', signature(x='RasterLayer', direction='ANY'), function(x, direction='y', filename='', ...) { filename <- trim(filename) outRaster <- raster(x) if (direction[1] == 1) { direction <- 'x' } else if (direction[1] == 2) { direction <- 'y' } if (!(direction %in% c('y', 'x'))) { stop('direction should be y or x') } if (!canProcessInMemory(outRaster, 2) && filename == '') { filename <- rasterTmpFile() inmemory = FALSE } else { inmemory = TRUE } if ( inmemory ) { x <- getValues(x, format='matrix') if (direction == 'y') { x <- x[nrow(x):1,] } else { x <- x[,ncol(x):1] } outRaster <- setValues(outRaster, as.vector(t(x))) if (filename != '') { outRaster = writeRaster(outRaster, filename=filename, ...) } } else { tr <- blockSize(outRaster) pb <- pbCreate(tr$n, label='flip', ...) outRaster <- writeStart(outRaster, filename=filename, datatype=dataType(x), ... ) if (direction == 'y') { nr <- nrow(outRaster) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- matrix(v, ncol=ncol(x), byrow=TRUE) v <- as.vector(t(v[nrow(v):1, ])) rownr <- nr - tr$row[i] - tr$nrows[i] + 2 outRaster <- writeValues(outRaster, v, rownr) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- matrix(v, ncol=ncol(x), byrow=TRUE) v <- as.vector(t(v[, ncol(v):1])) outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } } outRaster <- writeStop(outRaster) pbClose(pb) } return(outRaster) } ) setMethod('flip', signature(x='RasterStackBrick', direction='ANY'), function(x, direction='y', filename='', ...) { filename <- trim(filename) outRaster <- brick(x, values=FALSE) if (direction[1] == 1) { direction <- 'x' } else if (direction[1] == 2) { direction <- 'y' } if (!(direction %in% c('y', 'x'))) { stop('directions should be y or x') } if (!canProcessInMemory(outRaster, 2) && filename == '') { filename <- rasterTmpFile() inmemory = FALSE } else { inmemory = TRUE } nc <- outRaster@ncols if ( inmemory ) { x <- getValues(x) for (i in 1:NCOL(x)) { v <- matrix(x[,i], ncol=nc, byrow=TRUE) if (direction == 'y') { v <- v[nrow(v):1,] } else { v <- v[,ncol(v):1] } x[,i] <- as.vector(t(v)) } outRaster <- setValues(outRaster, x) if (filename != '') { outRaster = writeRaster(outRaster, filename=filename, ...) } } else { tr <- blockSize(outRaster) pb <- pbCreate(tr$n, label='flip', ...) if (inherits(x, 'RasterStack')) { dtype <- 'FLT4S' } else { dtype <- dataType(x) } outRaster <- writeStart(outRaster, filename=filename, datatype=dtype, ... ) if (direction == 'y') { trinv <- tr trinv$row <- rev(trinv$row) trinv$nrows <- rev(trinv$nrows) trinv$newrows <- cumsum(c(1,trinv$nrows))[1:length(trinv$nrows)] for (i in 1:tr$n) { vv <- getValues(x, row=trinv$row[i], nrows=trinv$nrows[i]) for (j in 1:NCOL(vv)) { v <- matrix(vv[,j], nrow=nc) vv[,j] <- as.vector(v[, ncol(v):1]) } outRaster <- writeValues(outRaster, vv, trinv$newrows[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { vv = getValues(x, row=tr$row[i], nrows=tr$nrows[i]) for (j in 1:NCOL(vv)) { v <- matrix(vv[,j], nrow=nc) vv[,j] <- as.vector(v[nrow(v):1, ]) } outRaster <- writeValues(outRaster, vv, tr$row[i]) pbStep(pb, i) } } outRaster <- writeStop(outRaster) pbClose(pb) } return(outRaster) } )
94 flowpath.R
# drain.R # This script calculates the drainage of a point on a DEM - in R! # written by A. Shortridge, 10/2013 # changes by Robert Hijmans flowPath <- function(x, p, ...) { r <- raster(x) if (length(p) > 1) { p <- cellFromXY(r, p[1:2]) } cell <- p row <- rowFromCell(r, cell) col <- colFromCell(r, cell) nr <- nrow(r) nc <- ncol(r) path <- NULL while (!is.na(x[cell])) { path <- c(path, cell) fd <- x[cell] row <- if(fd %in% c(32, 64, 128)) row - 1 else if(fd %in% c(8, 4, 2)) row + 1 else row col <- if(fd %in% c(32, 16, 8)) col - 1 else if(fd %in% c(128, 1, 2)) col + 1 else col cell <- cellFromRowCol(r, row, col) # Don't drain off the raster or drain NA cells on x! if (is.na(x[cell])) break # avoid cell i draining to j and j draining to i traps if (cell %in% path) break } return(path) } .flowPath1 <- function(x, p) { # This function creates a raster with 1s representing a path from # the start cell to the end of the flowpath. x is a flow raster # created with the terrain() function in raster. Returns a raster # where 1 represents a part of this path and 0 is off-path. out <- raster(x) if (length(p) > 1) { p <- cellFromXY(out, p[1:2]) } row <- rowFromCell(out, p) col <- colFromCell(out, p) out[row, col] <- 1 while (!is.na(x[row, col])) { # not in a pit out[row, col] <- 1 fdval <- x[row, col] col <- if(fdval %in% c(32, 16, 8)) col - 1 else if(fdval %in% c(128, 1, 2)) col + 1 else col row <- if(fdval %in% c(32, 64, 128)) row - 1 else if(fdval %in% c(8, 4, 2)) row + 1 else row # Don't drain off the raster! if (row < 1 || row > dim(x)[1] || col < 1 || col > dim(x)[2]) break # Don't drain NA cells on x! if (is.na(x[row, col])) break # avoid cell i draining to j and j draining to i traps if (!is.na(out[row, col])) break } return(out) }
95 focalFun.R
# Author: Robert J. Hijmans # Date : March 2014 # Version 1.0 # Licence GPL v3 #if ( !isGeneric(focalFun) ) { # setGeneric(focalFun, function(x, ...) # standardGeneric(focalFun)) #} #setMethod('focalFun', signature(x='Raster'), .focalFun <- function(x, fun, ngb=5, filename='', ...) { out <- raster(x) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) if (canProcessInMemory(x)) { v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE) v <- snow::parApply(cl, v, 1, fun) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='focalFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE) v <- snow::parApply(cl, v, 1, fun) out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } else { if (canProcessInMemory(x)) { v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE) v <- apply(v, 1, fun) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='focalFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE) v <- apply(v, 1, fun) out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } #)
96 focal.R
# Author: Robert J. Hijmans # Date : October 2011 # Version 1.0 # Licence GPL v3 .checkngb <- function(ngb, mustBeOdd=FALSE) { ngb <- as.integer(round(ngb)) if (length(ngb) == 1) { ngb <- c(ngb, ngb) } else if (length(ngb) > 2) { stop('ngb should be a single value or two values') } if (min(ngb) < 1) { stop(ngb should be larger than 1) } if (mustBeOdd) { if (any(ngb %% 2 == 0)) { stop('neighborhood size must be an odd number') } } return(ngb) } .wwarn <- function() { if (! isTRUE(options('rasterFocalWarningGiven'))) { warning('the computation of the weights matrix has changed in version 2.1-35. The sum of weights is now 1') options(rasterFocalWarningGiven=TRUE) } } .getW <- function(w) { if (length(w) == 1) { w <- round(w) stopifnot(w > 0) w <- matrix(1, ncol=w, nrow=w) w <- w / sum(w) .wwarn() } else if (length(w) == 2) { w <- round(w) w <- matrix(1, ncol=w[1], nrow=w[2]) w <- w / sum(w) .wwarn() } if (! is.matrix(w) ) { stop('w should be a single number, two numbers, or a matrix') } return(w) } if (!isGeneric(focal)) { setGeneric(focal, function(x, ...) standardGeneric(focal)) } setMethod('focal', signature(x='RasterLayer'), function(x, w, fun, filename='', na.rm=FALSE, pad=FALSE, padValue=NA, NAonly=FALSE, ...) { stopifnot(hasValues(x)) # mistakes because of differences with old focal and old focalFilter dots <- list(...) if (!is.null(dots$filter)) { warning('argument filter is ignored!') } if (!is.null(dots$ngb)) { warning('argument ngb is ignored!') } # w <- .getW(w) stopifnot(is.matrix(w)) d <- dim(w) if (prod(d) == 0) { stop('ncol and nrow of w must be > 0') } if (min(d %% 2) == 0) { stop('w must have uneven sides') } # to get the weights in the (by row) order for the C routine # but keeping nrow and ncol as-is w[] <- as.vector(t(w)) out <- raster(x) filename <- trim(filename) padrows <- FALSE if (pad) { padrows <- TRUE } gll <- as.integer(.isGlobalLonLat(out)) if (gll) { pad <- TRUE } if (NAonly) { na.rm <- TRUE } dofun <- TRUE domean <- FALSE if (missing(fun)) { dofun <- FALSE domean <- FALSE } else { fun2 <- .makeTextFun(fun) if (is.character(fun2)) { if (fun2=='mean') { domean <- TRUE dofun <- FALSE } else if (fun2 == 'sum') { dofun <- FALSE } } } if (dofun) { e <- new.env() if (na.rm) { runfun <- function(x) as.double( fun(x, na.rm=TRUE) ) } else { runfun <- function(x) as.double( fun(x) ) } } NAonly <- as.integer(NAonly) narm <- as.integer(na.rm) domean <- as.integer(domean) if (canProcessInMemory(out)) { if (pad) { # this should be done in C, but for now.... f <- floor(d / 2) v <- as.matrix(x) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) } else { if (dofun) { v <- .Call('focal_fun', values(x), w, as.integer(dim(out)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', values(x), w, as.integer(dim(out)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } } else { out <- writeStart(out, filename,...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label='focal', ...) addr <- floor(nrow(w) / 2) addc <- floor(ncol(w) / 2) nc <- ncol(out) nc1 <- 1:(nc * addc) if (pad) { f <- floor(d / 2) v <- getValues(x, row=1, nrows=tr$nrows[1]+addr) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[ , -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v, 1) pbStep(pb) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr)) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } i <- tr$n v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } else { v <- getValues(x, row=1, nrows=tr$nrows[1]+addr) if (dofun) { v <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[1]+addr, nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[1]+addr, nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } out <- writeValues(out, v, 1) pbStep(pb) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr)) if (dofun) { v <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } i <- tr$n v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr) if (dofun) { v <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[i]+addr, nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster') } else { v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[i]+addr, nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster') } out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) } return(out) } )
97 focalWeight.R
# Author: Robert J. Hijmans # Date : June 2013 # Version 1.0 # Licence GPL v3 .circular.weight <- function(rs, d) { nx <- 1 + 2 * floor(d/rs[1]) ny <- 1 + 2 * floor(d/rs[2]) m <- matrix(ncol=nx, nrow=ny) m[ceiling(ny/2), ceiling(nx/2)] <- 1 if (nx == 1 & ny == 1) { return(m) } else { x <- raster(m, xmn=0, xmx=nx*rs[1], ymn=0, ymx=ny*rs[2], crs='+proj=utm +zone=1') d <- as.matrix(distance(x)) <= d d / sum(d) } } .Gauss.weight <- function(rs, sigma) { if (length(sigma) == 1) { d <- 3 * sigma } else { d <- sigma[2] sigma <- sigma[1] } nx <- 1 + 2 * floor(d/rs[1]) ny <- 1 + 2 * floor(d/rs[2]) m <- matrix(ncol=nx, nrow=ny) xr <- (nx * rs[1]) / 2 yr <- (ny * rs[2]) / 2 r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1') p <- xyFromCell(r, 1:ncell(r))^2 # according to http://en.wikipedia.org/wiki/Gaussian_filter m <- 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2)) m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE) # sum of weights should add up to 1 m / sum(m) } .rectangle.weight <- function(rs, d) { d <- rep(d, length.out=2) nx <- 1 + 2 * floor(d[1]/rs[1]) ny <- 1 + 2 * floor(d[2]/rs[2]) m <- matrix(1, ncol=nx, nrow=ny) m / sum(m) } focalWeight <- function(x, d, type=c('circle', 'Gauss', 'rectangle')) { type <- match.arg(type) x <- res(x) if (type == 'circle') { .circular.weight(x, d[1]) } else if (type == 'Gauss') { if (!length(d) %in% 1:2) { stop(If type=Gauss, d should be a vector of length 1 or 2) } .Gauss.weight(x, d) } else { .rectangle.weight(x, d) } } ..simple.circular.weight <- function(radius) { # based on a function provided by Thomas Cornulier x <- -radius:radius n <- length(x) d <- sqrt(rep(x, n)^2 + rep(x, each=n)^2) <= radius matrix(d + 0, n, n) / sum(d) } ..simple.Gauss.weight <- function(n, sigma) { # need to adjust for non-square cells to distance.... m <- matrix(ncol=n, nrow=n) col <- rep(1:n, n) row <- rep(1:n, each=n) x <- col - ceiling(n/2) y <- row - ceiling(n/2) # according to http://en.wikipedia.org/wiki/Gaussian_filter m[cbind(row, col)] <- 1/(2*pi*sigma^2) * exp(-(x^2+y^2)/(2*sigma^2)) # sum of weights should add up to 1 m / sum(m) }
98 fourCellsFromXY.R
# Author: Robert J. Hijmans # Date : March 2009, August 2012 # Licence GPL v3 # updated November 2011 # version 1.0 fourCellsFromXY <- function(object, xy, duplicates=TRUE) { # if duplicates is TRUE, the same cell number can be returned # twice (if point in the middle of division between two cells) or # four times (if point in center of cell) r <- raster(object) # use small object stopifnot(is.matrix(xy)) cells <- cellFromXY(r, xy) rows <- rowFromCell(r, cells) cols <- colFromCell(r, cells) cellsXY <- xyFromCell(r, cells) if (duplicates) { pos <- matrix(0, ncol=ncol(xy), nrow=nrow(xy)) pos[ xy[,1] > cellsXY[,1], 1 ] <- 1 pos[ xy[,1] < cellsXY[,1], 1 ] <- -1 pos[ xy[,2] < cellsXY[,2], 2 ] <- 1 pos[ xy[,2] > cellsXY[,2], 2 ] <- -1 } else { pos <- matrix(-1, ncol=ncol(xy), nrow=nrow(xy)) pos[ xy[,1] > cellsXY[,1], 1 ] <- 1 pos[ xy[,2] < cellsXY[,2], 2 ] <- 1 } poscol <- cols + pos[,1] if (.isGlobalLonLat(r)) { poscol[poscol==0] <- ncol(r) poscol[poscol==ncol(r)+1] <- 1 } else { poscol[poscol==0] <- 2 poscol[poscol==ncol(r)+1] <- ncol(r) - 1 } posrow <- rows + pos[,2] posrow[posrow==0] <- 2 posrow[posrow==nrow(r)+1] <- nrow(r) - 1 four <- matrix(cells, ncol=4, nrow=nrow(xy)) four[,2] <- cellFromRowCol(r, posrow, cols) four[,3] <- cellFromRowCol(r, posrow, poscol) four[,4] <- cellFromRowCol(r, rows, poscol) return(four) }
99 frbind.R
# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 # friendly rbind # rbinds data.frames with different column names .frbind <- function(x, ...) { if (! inherits(x, 'data.frame') ) { x <- data.frame(x) } d <- list(...) if (length(d) == 0) { return(x) } for (i in 1:length(d)) { dd <- d[[i]] if (! inherits(dd, 'data.frame')) { dd <- data.frame(dd) } cnx <- colnames(x) cnd <- colnames(dd) e <- cnx[(cnx %in% cnd)] for (j in e) { if (class(x[,j]) != class(dd[,j])) { x[,j] <- as.character(x[,j]) dd[,j] <- as.character(dd[,j]) } } a <- which(!cnd %in% cnx) if (length(a) > 0) { zz <- dd[NULL, a, drop=FALSE] zz[1:nrow(x),] <- NA x <- cbind(x, zz) } b <- which(!cnx %in% cnd) if (length(b) > 0) { zz <- x[NULL, b, drop=FALSE] zz[1:nrow(dd),] <- NA dd <- cbind(dd, zz) } x <- rbind(x, dd) } x }
100 freq.R
# Author: Robert J. Hijmans # Date : March 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(freq)) { setGeneric(freq, function(x, ...) standardGeneric(freq)) } setMethod('freq', signature(x='RasterLayer'), function(x, digits=0, value=NULL, useNA=ifany, progress='', ...) { if (!is.null(value)) { return(.count(x, value, digits=digits, progress=progress, ...)) } if (canProcessInMemory(x, 3)) { d <- round(getValues(x), digits=digits) res <- table( d, useNA=useNA ) } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress, label='freq') z <- vector(length=0) for (i in 1:tr$n) { d <- round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits) res <- table(d, useNA=useNA ) res <- cbind(as.numeric(unlist(as.vector(dimnames(res)))), as.vector(res)) z <- rbind(z, res) pbStep(pb, i) } res <- tapply(z[,2], z[,1], sum) pbClose(pb) } res <- cbind(as.numeric(unlist(as.vector(dimnames(res)))), as.vector(res)) colnames(res) <- c('value', 'count') return(res) } ) setMethod('freq', signature(x='RasterStackBrick'), function(x, digits=0, value=NULL, useNA=ifany, merge=FALSE, progress='', ...) { if (!is.null(value)) { return(.count(x, value, digits=digits, progress=progress, ...)) } nl <- nlayers(x) res <- list() pb <- pbCreate(nl, progress=progress, label='freq') for (i in 1:nl) { res[[i]] <- freq( raster(x, i), useNA=useNA, progress='', ...) pbStep(pb, i) } pbClose(pb) names(res) <- ln <- names(x) if (merge) { r <- res[[1]] colnames(r)[2] <- ln[1] if (nl > 1) { for (i in 2:nl) { x <- res[[i]] colnames(x)[2] <- ln[i] r <- merge(r, x, by=1, all=TRUE) } } return(r) } return(res) } ) .count <- function(x, value, digits=0, progress='', ...) { value <- value[1] if (nlayers(x) > 1) { if (canProcessInMemory(x, 2)) { if (is.na(value)) { v <- colSums(is.na(getValues(x))) } else { v <- round(getValues(x), digits=digits) == value v <- colSums(v, na.rm=TRUE) } } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress) v <- 0 for (i in 1:tr$n) { vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (is.na(value)) { v <- v + colSums(is.na(vv)) } else { vv <- round(v, digits=digits) == value v <- v + colSums(vv, na.rm=TRUE) } pbStep(pb, i) } pbClose(pb) } return(v) } else { if (canProcessInMemory(x, 2)) { if (is.na(value)) { x <- sum(is.na(getValues(x))) } else { v <- na.omit(round(getValues(x), digits=digits)) x <- sum(v == value) } return(x) } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress) r <- 0 for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (is.na(value)) { r <- r + sum(is.na(v)) } else { v <- na.omit(round(v, digits=digits)) r <- r + sum(v == value) } pbStep(pb, i) } pbClose(pb) return(r) } } }
101 fullFileName.R
# raster package # Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : September 2009 # Version 0.9 # Licence GPL v3 # this function adds the working directory to a filename, if the filename has no path name # and, thus, presumably exists in the working directory. # Storing the full file name is to avoid that a filename becomes invalid if the working directory # changes during an R session .fullFilename <- function(x, expand=FALSE) { x <- trim(x) if (identical(basename(x), x)) { x <- file.path(getwd(), x) } if (expand) { x <- path.expand(x) } return(x) }
102 gainoffset.R
# Author: Robert J. Hijmans # Date : September 2010 # Version 1.0 # Licence GPL v3 'gain<-' <- function(x, value) { value <- as.numeric(value[1]) if (inherits(x, 'RasterStack')) { x@layers <- lapply( x@layers, function(z) { if (fromDisk(x)) { z@data@gain <- value } else { z <- z * value } return(z) } ) } else { if (fromDisk(x)) { x@data@gain <- value } else { x <- x * value } } return(x) } gain <- function(x) { if (inherits(x, 'RasterStack')) { r <- sapply( x@layers, function(z) { z@data@gain } ) } else { r <- x@data@gain } return(r) } 'offs<-' <- function(x, value) { value <- as.numeric(value[1]) if (inherits(x, 'RasterStack')) { x@layers <- lapply( x@layers, function(z) { if (fromDisk(z)) { z@data@offset <- value } else { z <- z + offset } return(z) } ) } else { if (fromDisk(x)) { x@data@offset <- value } else { x <- x + value } } return(x) } offs <- function(x) { if (inherits(x, 'RasterStack')) { r <- sapply( x@layers, function(z) { z@data@offset } ) } else { r <- x@data@offset } return(r) }
103 gdalFormats.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 .isSupportedFormat <- function(dname) { res <- dname %in% c(.nativeDrivers(), 'ascii', 'big.matrix', 'CDF') if (!res) { res <- .isSupportedGDALFormat(dname) } return(res) } .gdalWriteFormats <- function() { .requireRgdal() gd <- rgdal::gdalDrivers() gd <- as.matrix( gd[gd[,3] == T, ] ) i <- which(gd[,1] %in% c('VRT', 'MEM', 'MFF', 'MFF2')) gd[-i,] } .isSupportedGDALFormat <- function(dname) { .requireRgdal() gd <- .gdalWriteFormats() res <- dname %in% gd[,1] if (!res) { stop(paste(dname, is not a supported file format. See writeFormats() ) ) } return(res) } #.GDALDataTypes <- c('Unknown', 'Byte', 'UInt16', 'Int16', 'UInt32','Int32', 'Float32', 'Float64', ' # what are these? CInt16', 'CInt32', 'CFloat32', 'CFloat64') as in C? # this needs to get fancier; depending on object and the abilties of the drivers .getGdalDType <- function(dtype, format='') { if (!(dtype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'INT4U', 'FLT4S', 'FLT8S'))) { stop('not a valid data type') } if (dtype == 'INT1S') { # gdal does not have this warning('data type INT1S is not available in GDAL. Changed to INT2S (you may prefer INT1U (Byte))') dtype <- 'INT2S' } type <- .shortDataType(dtype) size <- dataSize(dtype) * 8 if (format=='BMP' | format=='ADRG' | format=='IDA' | format=='SGI') { return('Byte') } if (format=='PNM') { if (size == 8) { return('Byte') } else { return('UInt16') } } if (format=='RMF') { if (type == 'FLT') { return('Float64') } } if (type == 'LOG') { warning('data type LOG is not available in GDAL. Changed to INT1U') return('Byte') } if (type == 'INT') { type <- 'Int' if (size == 64) { size <- 32 warning('8 byte integer values not supported by rgdal, changed to 4 byte integer values') } if (! dataSigned(dtype) ) { if (size == 8) { return('Byte') } else { type <- paste('U', type, sep='') } } } else { type <- 'Float' } return(paste(type, size, sep='')) } .getRasterDType <- function(dtype) { if (!(dtype %in% c('Byte', 'UInt16', 'Int16', 'UInt32','Int32', 'Float32', 'Float64', 'CInt16', 'CInt32', 'CFloat32', 'CFloat64'))) { return ('FLT4S') } else if (dtype == 'Byte') { return('INT1U') } else if (dtype == 'UInt16') { return('INT2U') } else if (dtype == 'Int16' | dtype == 'CInt16') { return('INT2S') } else if (dtype == 'UInt32') { return('INT4U') } else if (dtype == 'Int32' | dtype == 'CInt32') { return('INT4S') } else if (dtype == 'Float32' | dtype == 'CFloat32' ) { return('FLT4S') } else if (dtype == 'Float64' | dtype == 'CFloat64' ) { return('FLT8S') } else { return('FLT4S') } }
104 gdal.R
# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 .requireRgdal <- function(stopIfAbsent=TRUE) { y <- getOption('rasterGDALLoaded') w <- getOption('warn') options('warn'=-1) x <- isTRUE( try( require(rgdal, quietly=TRUE ) ) ) options('warn'= w) if (! isTRUE(y) ) { if (x) { #pkg.info <- utils::packageDescription('rgdal') #test <- utils::compareVersion(pkg.info[[Version]], 0.7-21) > 0 #if (!test) { # stop('you use rgdal version: ', pkg.info[[Version]], '\nYou need version 0.7-22 or higher') #} options('rasterGDALLoaded'=TRUE) return(TRUE) } else if (stopIfAbsent) { stop(package 'rgdal' is not available) } else { return(FALSE) } } return(TRUE) }
105 GDALtransient.R
# Author: Robert J. Hijmans # contact: r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 # based on create2GDAL and rgdal::saveDataset from the rgdal package # authors: Timothy H. Keitt, Roger Bivand, Edzer Pebesma, Barry Rowlingson .getGDALtransient <- function(r, filename, options, NAflag, ...) { .GDALnodatavalue <- function(x){ if (x == 'Float32') return(-3.4E38) if (x == 'Float64') return(-1.7E308) if (x == 'Int32') return(-2147483647) if (x == 'Int16') return(-32768) if (x == 'Int8') return(-128) if (x == 'Byte') return(255) if (x == 'UInt16') return(65535) if (x == 'UInt32') return(2147483647) #(4294967295) <- not supported as integer in R stop('cannot find matching nodata value') } nbands <- nlayers(r) ct <- r@legend@colortable if (length(ct) > 0 ) { hasCT <- TRUE } else { hasCT <- FALSE } r <- raster(r) datatype <- .datatype(...) overwrite <- .overwrite(...) gdalfiletype <- .filetype(filename=filename, ...) .isSupportedFormat(gdalfiletype) if (filename == ) { stop('provide a filename') } if (file.exists( filename)) { if (!overwrite) { stop(filename exists; use overwrite=TRUE) } else if (!file.remove( filename)) { stop(cannot delete existing file. permission denied.) } } dataformat <- .getGdalDType(datatype, gdalfiletype) if (dataformat != 'Byte') hasCT <- FALSE if (missing(NAflag)) { NAflag <- .GDALnodatavalue(dataformat) } if (gdalfiletype=='GTiff') { bytes <- ncell(r) * dataSize(datatype) * nbands if (bytes > (4 * 1024 * 1024 * 1000) ) { # ~ 4GB options <- c(options, 'BIGTIFF=YES') } options <- c(options, COMPRESS=LZW) } driver <- new(GDALDriver, gdalfiletype) transient <- try( new(GDALTransientDataset, driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL), silent=TRUE) if (class(transient) == 'try-error') { if (dataformat == Float64) { dataformat <- Float32 } transient <- new(GDALTransientDataset, driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL) } for (i in 1:nbands) { b <- new(GDALRasterBand, transient, i) rgdal::GDALcall(b, SetNoDataValue, NAflag) if (hasCT) { rgdal::GDALcall(b, SetRasterColorTable, t(col2rgb(ct, TRUE))) } } if (rotated(r)) { gt <- r@rotation@geotrans } else { #if (flip) { # gt <- c(xmin(r), xres(r), 0, 0, ymax(r), yres(r)) # cat('flipping (this creates an invalid RasterLayer)\n') #} else { gt <- c(xmin(r), xres(r), 0, ymax(r), 0, -yres(r)) #} } rgdal::GDALcall(transient, SetGeoTransform, gt) # as.character to ensure NA is character rgdal::GDALcall(transient, SetProject, as.character(projection(r))) if (is.null(options)) { options <- '' } return(list(transient, NAflag, options, dataformat)) }
106 Geary.R
# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 .getFilter <- function(w, warn=TRUE) { if (!is.matrix(w)) { w <- .checkngb(w) w <- matrix(1, nrow=w[1], ncol=(w[2])) w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0 } else { if (w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] != 0) { if (warn) { warning('central cell of weights matrix (filter) was set to zero') } w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0 } stopifnot(all(w >= 0)) } if (min(dim(w) %% 2)==0) { stop('dimensions of weights matrix (filter) must be uneven') } w } Geary <- function(x, w= matrix(1, 3, 3)) { w <- .getFilter(w, warn=FALSE) i <- trunc(length(w)/2)+1 n <- ncell(x) - cellStats(x, 'countNA') fun <- function(x,...) sum(w*(x-x[i])^2, ...) w2 <- w w2[] <- 1 Eij <- cellStats(focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE), sum) if (sum(! unique(w) %in% 0:1) > 0) { x <- calc(x, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal(x, w=w, na.rm=TRUE, pad=TRUE ) } else { w[w==0] <- NA W <- focal(x, w=w, fun=function(x, ...){ sum(!is.na(x)) }, pad=TRUE ) } z <- 2 * cellStats(W, sum) * cellStats((x - cellStats(x, mean))^2, sum) (n-1)*Eij/z } GearyLocal <- function(x, w=matrix(1, 3, 3)) { w <- .getFilter(w) i <- trunc(length(w)/2)+1 fun <- function(x,...) sum(w*(x-x[i])^2, ...) w2 <- w w2[] <- 1 Eij <- focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE) s2 <- cellStats(x, sd)^2 if (ncell(x) < 1000000) { n <- ncell(x) - cellStats(x, 'countNA' ) } else { n <- ncell(x) } s2 <- (s2 * (n-1)) / n Eij / s2 }
107 getData.R
# Download geographic data and return as R object # Author: Robert J. Hijmans, r.hijmans@gmail.com # License GPL3 # Version 0.9 # October 2008 getData <- function(name='GADM', download=TRUE, path='', ...) { path <- .getDataPath(path) if (name=='GADM') { .GADM(..., download=download, path=path) } else if (name=='SRTM') { .SRTM(..., download=download, path=path) } else if (name=='alt') { .raster(..., name=name, download=download, path=path) } else if (name=='worldclim') { .worldclim(..., download=download, path=path) } else if (name=='CMIP5') { .cmip5(..., download=download, path=path) } else if (name=='ISO3') { ccodes()[,c(2,1)] } else if (name=='countries') { .countries(download=download, path=path, ...) } else { stop(name, ' not recognized as a valid name.') } } .download <- function(aurl, filename) { fn <- paste(tempfile(), '.download', sep='') res <- download.file(url=aurl, destfile=fn, method=auto, quiet = FALSE, mode = wb, cacheOK = TRUE) if (res == 0) { w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) if (! file.rename(fn, filename) ) { # rename failed, perhaps because fn and filename refer to different devices file.copy(fn, filename) file.remove(fn) } } else { stop('could not download the file' ) } } .ISO <- function() { ccodes() } ccodes <- function() { path <- paste(system.file(package=raster), /external, sep='') d <- read.csv(paste(path, /countries.csv, sep=), stringsAsFactors=FALSE, encoding=UTF-8) return(as.matrix(d)) } .getCountry <- function(country='') { country <- toupper(trim(country[1])) # if (nchar(country) < 3) { # stop('provide a 3 letter ISO country code') # } cs <- ccodes() try (cs <- toupper(cs)) iso3 <- substr(toupper(country), 1, 3) if (iso3 %in% cs[,2]) { return(iso3) } else { iso2 <- substr(toupper(country), 1, 3) if (iso2 %in% cs[,3]) { i <- which(country==cs[,3]) return( cs[i,2] ) } else if (country %in% cs[,1]) { i <- which(country==cs[,1]) return( cs[i,2] ) } else { stop('provide a valid name or 3 letter ISO country code; you can get a list with: getData(ISO3)') } } } .getDataPath <- function(path) { path <- trim(path) if (path=='') { path <- .dataloc() } else { if (substr(path, nchar(path)-1, nchar(path)) == '//' ) { p <- substr(path, 1, nchar(path)-2) } else if (substr(path, nchar(path), nchar(path)) == '/' | substr(path, nchar(path), nchar(path)) == '\\') { p <- substr(path, 1, nchar(path)-1) } else { p <- path } if (!file.exists(p) & !file.exists(path)) { stop('path does not exist: ', path) } } if (substr(path, nchar(path), nchar(path)) != '/' & substr(path, nchar(path), nchar(path)) != '\\') { path <- paste(path, /, sep=) } return(path) } .GADM <- function(country, level, download, path) { # if (!file.exists(path)) { dir.create(path, recursive=T) } country <- .getCountry(country) if (missing(level)) { stop('provide a level= argument; levels can be 0, 1, or 2 for most countries, and higer for some') } filename <- paste(path, country, '_adm', level, .RData, sep=) if (!file.exists(filename)) { if (download) { theurl <- paste(http://biogeo.ucdavis.edu/data/gadm2/R/, country, '_adm', level, .RData, sep=) .download(theurl, filename) if (!file.exists(filename)) { cat(\nCould not download file -- perhaps it does not exist \n) } } else { cat(\nFile not available locally. Use 'download = TRUE'\n) } } if (file.exists(filename)) { thisenvir = new.env() data <- get(load(filename, thisenvir), thisenvir) return(data) } } .countries <- function(download, path, ...) { # if (!file.exists(path)) { dir.create(path, recursive=T) } filename <- paste(path, 'countries.RData', sep=) if (!file.exists(filename)) { if (download) { theurl <- paste(http://biogeo.ucdavis.edu/data/diva/misc/countries.RData, sep=) .download(theurl, filename) if (!file.exists(filename)) { cat(\nCould not download file -- perhaps it does not exist \n) } } else { cat(\nFile not available locally. Use 'download = TRUE'\n) } } if (file.exists(filename)) { thisenvir = new.env() data <- get(load(filename, thisenvir), thisenvir) return(data) } } .cmip5 <- function(var, model, rcp, year, res, lon, lat, path, download=TRUE) { if (!res %in% c(2.5, 5, 10)) { stop('resolution should be one of: 2.5, 5, 10') } if (res==2.5) { res <- '2-5' } var <- tolower(var[1]) vars <- c('tmin', 'tmax', 'prec', 'bio') stopifnot(var %in% vars) var <- c('tn', 'tx', 'pr', 'bi')[match(var, vars)] model <- toupper(model) models <- c('AC', 'BC', 'CC', 'CE', 'CN', 'GF', 'GD', 'GS', 'HD', 'HG', 'HE', 'IN', 'IP', 'MI', 'MR', 'MC', 'MP', 'MG', 'NO') stopifnot(model %in% models) rcps <- c(26, 45, 60, 85) stopifnot(rcp %in% rcps) stopifnot(year %in% c(50, 70)) m <- matrix(c(0,1,1,0,1,1,1,1,1,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,0,0,1,0,1,1,1,0,0,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1), ncol=4) i <- m[which(model==models), which(rcp==rcps)] if (!i) { warning('this combination of rcp and model is not available') return(invisible(NULL)) } path <- paste(path, '/cmip5/', res, 'm/', sep='') dir.create(path, recursive=TRUE, showWarnings=FALSE) zip <- tolower(paste(model, rcp, var, year, '.zip', sep='')) theurl <- paste('http://biogeo.ucdavis.edu/data/climate/cmip5/', res, 'm/', zip, sep='') zipfile <- paste(path, zip, sep='') if (var == 'bi') { n <- 19 } else { n <- 12 } tifs <- paste(extension(zip, ''), 1:n, '.tif', sep='') files <- paste(path, tifs, sep='') fc <- sum(file.exists(files)) if (fc < n) { if (!file.exists(zipfile)) { if (download) { .download(theurl, zipfile) if (!file.exists(zipfile)) { cat(\n Could not download file -- perhaps it does not exist \n) } } else { cat(\nFile not available locally. Use 'download = TRUE'\n) } } unzip(zipfile, exdir=dirname(zipfile)) } stack(paste(path, tifs, sep='')) } #.cmip5(var='prec', model='BC', rcp=26, year=50, res=10, path=getwd()) .worldclim <- function(var, res, lon, lat, path, download=TRUE) { if (!res %in% c(0.5, 2.5, 5, 10)) { stop('resolution should be one of: 0.5, 2.5, 5, 10') } if (res==2.5) { res <- '2-5' } stopifnot(var %in% c('tmean', 'tmin', 'tmax', 'prec', 'bio', 'alt')) path <- paste(path, 'wc', res, '/', sep='') dir.create(path, showWarnings=FALSE) if (res==0.5) { lon <- min(180, max(-180, lon)) lat <- min(90, max(-60, lat)) rs <- raster(nrows=5, ncols=12, xmn=-180, xmx=180, ymn=-60, ymx=90 ) row <- rowFromY(rs, lat) - 1 col <- colFromX(rs, lon) - 1 rc <- paste(row, col, sep='') zip <- paste(var, '_', rc, '.zip', sep='') zipfile <- paste(path, zip, sep='') if (var == 'alt') { bilfiles <- paste(var, '_', rc, '.bil', sep='') hdrfiles <- paste(var, '_', rc, '.hdr', sep='') } else if (var != 'bio') { bilfiles <- paste(var, 1:12, '_', rc, '.bil', sep='') hdrfiles <- paste(var, 1:12, '_', rc, '.hdr', sep='') } else { bilfiles <- paste(var, 1:19, '_', rc, '.bil', sep='') hdrfiles <- paste(var, 1:19, '_', rc, '.hdr', sep='') } theurl <- paste('http://biogeo.ucdavis.edu/data/climate/worldclim/1_4/tiles/cur/', zip, sep='') } else { zip <- paste(var, '_', res, 'm_bil.zip', sep='') zipfile <- paste(path, zip, sep='') if (var == 'alt') { bilfiles <- paste(var, '.bil', sep='') hdrfiles <- paste(var, '.hdr', sep='') } else if (var != 'bio') { bilfiles <- paste(var, 1:12, '.bil', sep='') hdrfiles <- paste(var, 1:12, '.hdr', sep='') } else { bilfiles <- paste(var, 1:19, '.bil', sep='') hdrfiles <- paste(var, 1:19, '.hdr', sep='') } theurl <- paste('http://biogeo.ucdavis.edu/data/climate/worldclim/1_4/grid/cur/', zip, sep='') } files <- c(paste(path, bilfiles, sep=''), paste(path, hdrfiles, sep='')) fc <- sum(file.exists(files)) if (fc < 24) { if (!file.exists(zipfile)) { if (download) { .download(theurl, zipfile) if (!file.exists(zipfile)) { cat(\n Could not download file -- perhaps it does not exist \n) } } else { cat(\nFile not available locally. Use 'download = TRUE'\n) } } unzip(zipfile, exdir=dirname(zipfile)) for (h in paste(path, hdrfiles, sep='')) { x <- readLines(h) x <- c(x[1:14], 'PIXELTYPE SIGNEDINT', x[15:length(x)]) writeLines(x, h) } } if (var == 'alt') { st <- raster(paste(path, bilfiles, sep='')) } else { st <- stack(paste(path, bilfiles, sep='')) } projection(st) <- +proj=longlat +datum=WGS84 return(st) } .raster <- function(country, name, mask=TRUE, path, download, keepzip=FALSE, ...) { country <- .getCountry(country) path <- .getDataPath(path) if (mask) { mskname <- '_msk_' mskpath <- 'msk_' } else { mskname<-'_' mskpath <- '' } filename <- paste(path, country, mskname, name, .grd, sep=) if (!file.exists(filename)) { zipfilename <- filename extension(zipfilename) <- '.zip' if (!file.exists(zipfilename)) { if (download) { theurl <- paste(http://biogeo.ucdavis.edu/data/diva/, mskpath, name, /, country, mskname, name, .zip, sep=) .download(theurl, zipfilename) if (!file.exists(zipfilename)) { cat(\nCould not download file -- perhaps it does not exist \n) } } else { cat(\nFile not available locally. Use 'download = TRUE'\n) } } ff <- unzip(zipfilename, exdir=dirname(zipfilename)) if (!keepzip) { file.remove(zipfilename) } } if (file.exists(filename)) { rs <- raster(filename) } else { #patrn <- paste(country, '.', mskname, name, .grd, sep=) #f <- list.files(path, pattern=patrn) f <- ff[substr(ff, nchar(ff)-3, nchar(ff)) == '.grd'] if (length(f)==0) { warning('something went wrong') return(NULL) } else if (length(f)==1) { rs <- raster(f) } else { rs <- sapply(f, raster) cat('returning a list of RasterLayer objects\n') return(rs) } } projection(rs) <- +proj=longlat +datum=WGS84 return(rs) } .SRTM <- function(lon, lat, download, path) { stopifnot(lon >= -180 & lon <= 180) stopifnot(lat >= -60 & lat <= 60) rs <- raster(nrows=24, ncols=72, xmn=-180, xmx=180, ymn=-60, ymx=60 ) rowTile <- rowFromY(rs, lat) colTile <- colFromX(rs, lon) if (rowTile < 10) { rowTile <- paste('0', rowTile, sep='') } if (colTile < 10) { colTile <- paste('0', colTile, sep='') } f <- paste('srtm_', colTile, '_', rowTile, sep=) zipfilename <- paste(path, /, f, .ZIP, sep=) tiffilename <- paste(path, /, f, .TIF, sep=) if (!file.exists(tiffilename)) { if (!file.exists(zipfilename)) { if (download) { theurl <- paste(ftp://xftp.jrc.it/pub/srtmV4/tiff/, f, .zip, sep=) test <- try (.download(theurl, zipfilename) , silent=TRUE) if (class(test) == 'try-error') { theurl <- paste(http://hypersphere.telascience.org/elevation/cgiar_srtm_v4/tiff/zip/, f, .ZIP, sep=) test <- try (.download(theurl, zipfilename) , silent=TRUE) if (class(test) == 'try-error') { theurl <- paste(http://srtm.csi.cgiar.org/SRT-ZIP/SRTM_V41/SRTM_Data_GeoTiff/, f, .ZIP, sep=) .download(theurl, zipfilename) } } } else {cat('file not available locally, use download=TRUE\n') } } if (file.exists(zipfilename)) { unzip(zipfilename, exdir=dirname(zipfilename)) file.remove(zipfilename) } } if (file.exists(tiffilename)) { rs <- raster(tiffilename) projection(rs) <- +proj=longlat +datum=WGS84 return(rs) } else { stop('file not found') } }
108 getValuesBlock.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric(getValuesBlock)) { setGeneric(getValuesBlock, function(x, ...) standardGeneric(getValuesBlock)) } setMethod('getValuesBlock', signature(x='RasterStack'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) { stopifnot(hasValues(x)) stopifnot(row <= x@nrows) stopifnot(col <= x@ncols) stopifnot(nrows > 0) stopifnot(ncols > 0) row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 nlyrs <- nlayers(x) if (missing(lyrs)) { lyrs <- 1:nlyrs } else { lyrs <- lyrs[lyrs %in% 1:nlyrs] if (length(lyrs) == 0) { stop(no valid layers selected) } nlyrs <- length(lyrs) x <- x[[lyrs]] } startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) nc <- ncol(x) res <- matrix(ncol=nlyrs, nrow=nrows * ncols) inmem <- sapply(x@layers, function(x) x@data@inmemory) if (any(inmem)) { if (col==1 & ncols==nc) { cells <- startcell:lastcell } cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol) } for (i in 1:nlyrs) { xx <- x@layers[[lyrs[i]]] if ( inMemory(xx) ) { res[,i] <- xx@data@values[cells] } else { res[,i] <- .readRasterLayerValues(xx, row, nrows, col, ncols) } } colnames(res) <- names(x) res } ) setMethod('getValuesBlock', signature(x='RasterBrick'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) { stopifnot(hasValues(x)) row <- max(1, round(row)) col <- max(1, round(col)) stopifnot(row <= x@nrows) stopifnot(col <= x@ncols) nrows <- min(round(nrows), x@nrows-row+1) ncols <- min((x@ncols-col+1), round(ncols)) stopifnot(nrows > 0) stopifnot(ncols > 0) nlyrs <- nlayers(x) if (missing(lyrs)) { lyrs <- 1:nlyrs } else { lyrs <- lyrs[lyrs %in% 1:nlyrs] if (length(lyrs) == 0) { stop(no valid layers) } nlyrs <- length(lyrs) } if ( inMemory(x) ){ lastrow <- row + nrows - 1 if (col==1 & ncols==x@ncols) { rnge <- cellFromRowCol(x, c(row, lastrow), c(1, ncol(x))) res <- x@data@values[rnge[1]:rnge[2], , drop=FALSE] } else { lastcol <- col + ncols - 1 res <- x@data@values[cellFromRowColCombine(x, row:lastrow, col:lastcol), , drop=FALSE] } if (NCOL(res) > nlyrs) { res <- res[, lyrs, drop=FALSE] } colnames(res) <- names(x)[lyrs] } else if ( fromDisk(x) ) { res <- .readRasterBrickValues(x, row, nrows, col, ncols) if (NCOL(res) > nlyrs) { res <- res[, lyrs, drop=FALSE] } } else { # no data res <- ( matrix(rep(NA, nrows * ncols * nlyrs), ncol=nlyrs) ) colnames(res) <- names(x)[lyrs] } return(res) } ) setMethod('getValuesBlock', signature(x='RasterLayer'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), format='') { row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) if (!(validRow(x, row))) { stop(paste(row, 'is not a valid rownumber')) } if ( inMemory(x) ) { if (col==1 & ncols==ncol(x)) { res <- x@data@values[startcell:lastcell] } else { cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol) res <- x@data@values[cells] } } else if ( fromDisk(x)) { res <- .readRasterLayerValues(x, row, nrows, col, ncols) } else { # no values res <- rep(NA, nrows * ncols) } if (format=='matrix') { res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE ) colnames(res) <- col:lastcol rownames(res) <- row:lastrow } res } ) setMethod('getValuesBlock', signature(x='RasterLayerSparse'), function(x=1, row, nrows=1, col=1, ncols=(ncol(x)-col+1), format='') { row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) if (!(validRow(x, row))) { stop(paste(row, 'is not a valid rownumber')) } if ( inMemory(x) ) { i <- which(x@index >= startcell & x@index <= lastcell) if (length(i) > 0) { res <- cellFromRowColCombine(x, row:lastrow, col:lastcol) m <- match(i, res) res[] <- NA res[m] <- x@data@values[i] } else { res <- rep(NA, nrows * ncols) } } else if ( fromDisk(x) ) { # not yet implemented #if (! fromDisk(x)) { # return(rep(NA, times=(lastcell-startcell+1))) #} #res <- .readRasterLayerValues(x, row, nrows, col, ncols, is.open) } else { res <- rep(NA, nrows * ncols) } if (format=='matrix') { res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE ) colnames(res) <- col:lastcol rownames(res) <- row:lastrow } res } )
109 getValuesFocal.R
# Author: Robert J. Hijmans # Date : March 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric(getValuesFocal)) { setGeneric(getValuesFocal, function(x, row, nrows, ngb, ...) standardGeneric(getValuesFocal)) } setMethod(getValuesFocal, signature(x='Raster', row='missing', nrows='missing', ngb='numeric'), function(x, ngb, names=FALSE, ...) { getValuesFocal(x, 1, nrow(x), ngb, names=names, ...) }) setMethod(getValuesFocal, signature(x='Raster', row='numeric', nrows='numeric', ngb='numeric'), function(x, row, nrows, ngb, names=FALSE, padValue=NA, array=FALSE, ...) { nl <- nlayers(x) if (nl == 0) { stop(x has no values) } else if (nl > 1) { mm <- list() } xx <- raster(x) nc <- ncol(xx) row <- round(row) nrows <- round(nrows) if (!validRow(xx, row)) { stop(Not a valid row number) } if ( (row+nrows-1) > nrow(xx) ) { stop('nrows' is too high) } stopifnot(is.atomic(padValue)) geo <- couldBeLonLat(xx) mask <- FALSE if (is.matrix(ngb)) { w <- ngb ngb <- dim(w) w <- ! is.na(as.vector(t(w))) mask <- TRUE } ngb <- .checkngb(ngb, mustBeOdd=TRUE) ngbr <- floor(ngb[1]/2) ngbc <- floor(ngb[2]/2) startrow <- row-ngbr endrow <- row+nrows-1+ngbr sr <- max(1, startrow) # startrow er <- min(endrow, nrow(xx)) if (nl==1) { vv <- matrix(getValues(x, sr, (er-sr+1)), ncol=1) } else { vv <- getValues(x, sr, (er-sr+1)) } for (i in 1:nl) { v <- matrix(vv[,i], ncol=nc, byrow=TRUE) if (sr > startrow) { add <- sr - startrow v <- rbind(matrix(padValue, nrow=add, ncol=ncol(v)), v) } if (endrow > er) { add <- endrow - er v <- rbind(v, matrix(padValue, nrow=add, ncol=ncol(v))) } if (geo) { nv <- ncol(v) if (ngbc < nv) { v <- cbind(v[,(nv-ngbc+1):nv], v, v[,1:ngbc]) } else { stop('horizontal neighbourhood is too big') } } else { add <- matrix(padValue, ncol=ngbc, nrow=nrow(v)) v <- cbind(add, v, add) } v <- .Call('focal_get', as.vector(t(v)), as.integer(dim(v)), as.integer(ngb), NAOK=TRUE, PACKAGE='raster') m <- matrix(v, nrow=nrows*nc, byrow=TRUE) if (names) { rownames(m) <- cellFromRowCol(xx, row, 1):cellFromRowCol(xx, row+nrows-1,nc) colnames(m) <- paste('r', rep(1:ngb[1], each=ngb[2]), 'c', rep(1:ngb[2], ngb[1]), sep='') } if (mask) { m <- m[,mask,drop=FALSE] } if (nl == 1) { return(m) } else { mm[[i]] <- m } } if (array) { if (names) { dnms <- list(rownames(mm[[1]]), colnames(mm[[1]]), names(x)) } else { dnms <- list(NULL, NULL, names(x)) } mm <- array(unlist(mm), c(nrow(mm[[1]]), ncol(mm[[1]]), length(mm)), dimnames=dnms ) } else { names(mm) <- names(x) } return(mm) } )
110 getValues.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(getValues)) { setGeneric(getValues, function(x, row, nrows, ...) standardGeneric(getValues)) } setMethod(getValues, signature(x='RasterLayer', row='missing', nrows='missing'), function(x, format='') { cr <- c(x@ncols, x@nrows) # f <- is.factor(x) # if (f) { # labs <- labels(x) # } if ( inMemory(x) ) { x <- x@data@values } else if ( fromDisk(x) ) { x <- .readRasterLayerValues(x, 1, x@nrows) } else { x <- rep(NA, ncell(x)) } if (format=='matrix') { return ( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) ) #} else if (format =='array') { # return( array( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE), dim=c(cr, 1)) ) # } else if (f) { # x <- factor(x) # set labels? } return( x ) } ) setMethod(getValues, signature(x='RasterBrick', row='missing', nrows='missing'), function(x) { if (! inMemory(x) ) { if ( fromDisk(x) ) { x <- readAll(x) } else { return( matrix(rep(NA, ncell(x) * nlayers(x)), ncol=nlayers(x)) ) } } colnames(x@data@values) <- names(x) x@data@values } ) setMethod(getValues, signature(x='RasterStack', row='missing', nrows='missing'), function(x) { m <- matrix(nrow=ncell(x), ncol=nlayers(x)) colnames(m) <- names(x) for (i in 1:nlayers(x)) { m[,i] <- getValues(x@layers[[i]]) } m } ) setMethod(getValues, signature(x='RasterLayerSparse', row='missing', nrows='missing'), function(x, format='') { cr <- c(x@ncols, x@nrows) if ( inMemory(x) ) { i <- x@index v <- x@data@values x <- rep(NA, ncell(x)) x[i] <- v } else if ( fromDisk(x) ) { # not yet implemented ### x <- .readRasterLayerValues(x, 1, x@nrows) } else { x <- rep(NA, ncell(x)) } if (format=='matrix') { x <- matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) } return( x ) } )
111 getValuesRows.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='numeric'), function(x, row, nrows) { for (i in 1:nlayers(x)) { if (i==1) { v <- getValues(x@layers[[i]], row, nrows) res <- matrix(ncol=nlayers(x), nrow=length(v)) res[,1] <- v } else { res[,i] <- getValues(x@layers[[i]], row, nrows) } } colnames(res) <- names(x) res } ) setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='numeric'), function(x, row, nrows, format='') { row <- round(row) nrows <- round(nrows) stopifnot(validRow(x, row)) stopifnot(nrows > 0) row <- min(x@nrows, max(1, row)) endrow <- max(min(x@nrows, row+nrows-1), row) nrows <- endrow - row + 1 if (inMemory(x)){ startcell <- cellFromRowCol(x, row, 1) endcell <- cellFromRowCol(x, row+nrows-1, x@ncols) v <- x@data@values[startcell:endcell] } else if ( fromDisk(x) ) { v <- .readRasterLayerValues(x, row, nrows) } else { v <- rep(NA, nrows * x@ncols) } if (format=='matrix') { v <- matrix(v, nrow=nrows, byrow=TRUE) rownames(v) <- row:(row+nrows-1) colnames(v) <- 1:ncol(v) } return(v) } ) setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='numeric'), function(x, row, nrows) { if (! validRow(x, row)) { stop(row, ' is not a valid rownumber') } row <- min(x@nrows, max(1, round(row))) endrow <- max(min(x@nrows, row+round(nrows)-1), row) nrows <- endrow - row + 1 if ( inMemory(x) ){ startcell <- cellFromRowCol(x, row, 1) endcell <- cellFromRowCol(x, row+nrows-1, x@ncols) res <- x@data@values[startcell:endcell, ,drop=FALSE] } else if (fromDisk(x)) { res <- .readRasterBrickValues(x, row, nrows) } else { res <- matrix(NA, nrow=nrows*ncol(x), ncol=nlayers(x)) } colnames(res) <- names(x) res } ) setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='numeric'), function(x, row, nrows, format='') { row <- round(row) nrows <- round(nrows) stopifnot(validRow(x, row)) stopifnot(nrows > 0) row <- min(x@nrows, max(1, row)) endrow <- max(min(x@nrows, row+nrows-1), row) nrows <- endrow - row + 1 if (inMemory(x)){ i <- which(x@index >= startcell & x@index <= lastcell) if (length(i) > 0) { v <- cellFromRowColCombine(x, row:lastrow, col:lastcol) m <- match(i, v) v[] <- NA v[m] <- x@data@values[i] } else { v <- rep(NA, nrows * x@ncols) } } else if ( fromDisk(x) ) { # not yet implemented ## v <- .readRasterLayerValues(x, row, nrows) } else { v <- rep(NA, nrows * x@ncols) } if (format=='matrix') { v <- matrix(v, nrow=nrows, byrow=TRUE) rownames(v) <- row:(row+nrows-1) colnames(v) <- 1:ncol(v) } return(v) } )
112 gridDistance2.R
# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 .gridDistance2 <- function(x, filename='', ...) { # currently only works for planar data! rs <- res(x) xdist <- rs[1] ydist <- rs[2] xydist <- sqrt(xdist^2 + ydist^2) z1 <- z2 <- raster(x) nc <- ncol(z1) filename <- trim(filename) if (canProcessInMemory(z1)) { f <- rep(Inf, nc) z1a <- z2a <- raster(x) x <- getValues(x) a <- as.integer(dim(z1)) b <- c(xdist, ydist, xydist) z1a[] <- .Call('broom', x, f, a , b, as.integer(1), NAOK=TRUE, PACKAGE='raster') z2a[] <- .Call('broom', x, f, a , b, as.integer(0), NAOK=TRUE, PACKAGE='raster') x <- min(z1a, z2a) if (filename != '') { x <- writeRaster(x, filename, ...) } } else { tr <- blockSize(z1) pb <- pbCreate(tr$n*2, ...) z1 <- writeStart(z1, rasterTmpFile()) i <- 1 v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) f <- rep(Inf, nc) z <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(1), NAOK=TRUE, PACKAGE='raster') z1 <- writeValues(z1, z, tr$row[i]) f <- z[(length(z)-nc+1):length(z)] for (i in 2:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) z <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(1), NAOK=TRUE, PACKAGE='raster') z1 <- writeValues(z1, z, tr$row[i]) f <- z[(length(z)-nc+1):length(z)] pbStep(pb, i) } z1 <- writeStop(z1) z2 <- writeStart(z2, rasterTmpFile()) i <- tr$n v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) f <- rep(Inf, nc) z <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(0), NAOK=TRUE, PACKAGE='raster') z2 <- writeValues(z2, z, tr$row[i]) f <- z[1:nc] for (i in (tr$n-1):1) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) z <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(0), NAOK=TRUE, PACKAGE='raster') z2 <- writeValues(z2, z, tr$row[i]) f <- z[1:nc] pbStep(pb, i) } z2 <- writeStop(z2) x <- calc(stack(z1, z2), fun=min, filename=filename) file.remove(filename(z1)) file.remove(filename(z2)) } return(x) }
113 gridDistance.R
# Author: Jacob van Etten # email jacobvanetten@yahoo.com # Date : May 2010 # Version 1.1 # Licence GPL v3 # RH: updated for igraph (from igraph0) # sept 23, 2012 if (!isGeneric(gridDistance)) { setGeneric(gridDistance, function(x, ...) standardGeneric(gridDistance)) } setMethod(gridDistance, signature(RasterLayer), function(x, origin, omit=NULL, filename=, ...) { if( !require(igraph)) { stop('you need to install the igraph0 package to be able to use this function') } if (missing(origin)) { stop(you must supply an 'origin' argument) } if (! hasValues(x) ) { stop('cannot compute distance on a RasterLayer with no data') } lonlat <- couldBeLonLat(x) filename <- trim(filename) if (filename != & file.exists(filename)) { if (! .overwrite(...)) { stop(file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it) } } # keep canProcessInMemory for debugging # need to test more to see how much igraph can deal with if ( canProcessInMemory(x, n=10) ) { out <- raster(x) x <- getValues(x) # to avoid keeping values in memory twice oC <- which(x %in% origin) ftC <- which(!(x %in% omit)) v <- .calcDist(out, ncell(out), ftC, oC, lonlat=lonlat) v[is.infinite(v)] <- NA out <- setValues(out, v) if (filename != ) { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(x, n=1) pb <- pbCreate(tr$n*2 - 1, ...) #going up r1 <- writeStart(raster(x), rasterTmpFile(), overwrite=TRUE) for (i in tr$n:1) { chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) startCell <- (tr$row[i]-1) * ncol(x) chunkSize <- length(chunk) oC <- which(chunk %in% origin) ftC <- which(!(chunk %in% omit)) if (length(ftC) != 0) { if (i < tr$n) { firstRowftC <- firstRowftC + chunkSize chunkDist <- .calcDist(x, chunkSize=chunkSize + ncol(x), ftC=c(ftC, firstRowftC), oC=c(oC, firstRowftC), perCell=c(rep(0,times=length(oC)),firstRowDist), startCell=startCell, lonlat=lonlat)[1:chunkSize] } else { chunkDist <- .calcDist(x, chunkSize=chunkSize, ftC=ftC, oC=oC, perCell=0, startCell=startCell, lonlat=lonlat) } } else { if (i < tr$n) { firstRowftC <- firstRowftC + chunkSize } chunkDist <- rep(NA, tr$nrows[i] * ncol(r1)) } firstRow <- chunk[1:ncol(x)] firstRowDist <- chunkDist[1:ncol(x)] firstRowftC <- which(!(firstRow %in% omit)) firstRowDist <- firstRowDist[firstRowftC] chunkDist[is.infinite(chunkDist)] <- NA r1 <- writeValues(r1, chunkDist, tr$row[i]) pbStep(pb) } r1 <- writeStop(r1) #going down out <- writeStart(raster(x), filename=filename, overwrite=TRUE, ...) for (i in 1:tr$n) { chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) chunkSize <- length(chunk) startCell <- (tr$row[i]-1) * ncol(x) oC <- which(chunk %in% origin) ftC <- which(!(chunk %in% omit)) if (length(ftC) != 0) { if (i > 1) { chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i]) chunkDist[is.na(chunkDist)] <- Inf chunkDist <- pmin(chunkDist, .calcDist(x, chunkSize=chunkSize+ncol(x), ftC = c(lastRowftC, ftC+ncol(x)), oC = c(lastRowftC, oC+ncol(x)), perCell = c(lastRowDist, rep(0,times=length(oC))), startCell = startCell - ncol(x), lonlat=lonlat)[-(1:ncol(r1))]) } else { chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i]) chunkDist[is.na(chunkDist)] <- Inf chunkDist <- pmin(chunkDist, .calcDist(x, chunkSize=chunkSize, ftC=ftC, oC=oC, perCell=0, startCell=startCell, lonlat=lonlat)) } } else { chunkDist <- rep(NA, tr$nrows[i] * ncol(out)) } lastRow <- chunk[(length(chunk)-ncol(x)+1):length(chunk)] lastRowDist <- chunkDist[(length(chunkDist)-ncol(x)+1):length(chunkDist)] lastRowftC <- which(!(lastRow %in% omit)) lastRowDist <- lastRowDist[lastRowftC] chunkDist[is.infinite(chunkDist)] <- NA out <- writeValues(out, chunkDist, tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) return(out) } } ) .calcDist <- function(x, chunkSize, ftC, oC, perCell=0, startCell=0, lonlat) { if (length(oC) > 0) { #adj <- adjacency(x, fromCells=ftC, toCells=ftC, directions=8) adj <- adjacent(x, ftC, directions=8, target=ftC, pairs=TRUE) startNode <- max(adj)+1 #extra node to serve as origin adjP <- rbind(adj, cbind(rep(startNode, times=length(oC)), oC)) distGraph <- igraph::graph.edgelist(adjP, directed=TRUE) if (length(perCell) == 1) { if (perCell == 0) { perCell <- rep(0, times=length(oC)) } } if (lonlat) { distance <- pointDistance(xyFromCell(x,adj[,1]+startCell), xyFromCell(x,adj[,2]+startCell), longlat=TRUE) igraph::E(distGraph)$weight <- c(distance, perCell) } else { sameRow <- which(rowFromCell(x, adj[,1]) == rowFromCell(x, adj[,2])) sameCol <- which(colFromCell(x, adj[,1]) == colFromCell(x, adj[,2])) igraph::E(distGraph)$weight <- sqrt(xres(x)^2 + yres(x)^2) igraph::E(distGraph)$weight[sameRow] <- xres(x) igraph::E(distGraph)$weight[sameCol] <- yres(x) igraph::E(distGraph)$weight[(length(adj[,1])+1):(length(adj[,1])+length(oC))] <- perCell } shortestPaths <- igraph::shortest.paths(distGraph, startNode) shortestPaths <- shortestPaths[-(length(shortestPaths))] #chop startNode off if (length(shortestPaths) < chunkSize) { #add Inf values where shortest.paths() leaves off before completing all nodes shortestPaths <- c(shortestPaths, rep(Inf, times=chunkSize-length(shortestPaths))) } } else { shortestPaths <- rep(Inf, times=chunkSize) } return(shortestPaths) }
114 hdrBIL.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrBIL <- function(x, layout='BIL') { hdrfile <- x@file@name extension(hdrfile) <- '.hdr' thefile <- file(hdrfile, w) # open an txt file connectionis cat(NROWS , x@nrows, \n, file = thefile) cat(NCOLS , x@ncols, \n, file = thefile) cat(NBANDS , nlayers(x), \n, file = thefile) cat(NBITS , dataSize(x@file@datanotation) * 8, \n, file = thefile) btorder <- ifelse(x@file@byteorder == little, I, M) cat(BYTEORDER , btorder, \n, file = thefile) # PIXELTYPE should work for Gdal, and perhpas ArcGIS, see: # http://lists.osgeo.org/pipermail/gdal-dev/2006-October/010416.html dtype <- .shortDataType(x@file@datanotation) if (dtype == 'INT' | dtype == 'LOG' ) { pixtype <- ifelse(dataSigned(x@file@datanotation), SIGNEDINT, UNSIGNEDINT) } else { pixtype <- FLOAT } cat(PIXELTYPE , pixtype, \n, file = thefile) cat(LAYOUT , layout, \n, file = thefile) cat(SKIPBYTES 0\n, file = thefile) cat(ULXMAP , as.character(xmin(x) + 0.5 * xres(x)), \n, file = thefile) cat(ULYMAP , as.character(ymax(x) - 0.5 * yres(x)), \n, file = thefile) cat(XDIM , xres(x), \n, file = thefile) cat(YDIM , yres(x), \n, file = thefile) browbytes <- round(ncol(x) * dataSize(x@file@datanotation) ) cat(BANDROWBYTES , browbytes, \n, file = thefile) cat(TOTALROWBYTES , browbytes * nbands(x), \n, file = thefile) cat(BANDGAPBYTES 0\n, file = thefile) cat(NODATA , .nodatavalue(x), \n, file = thefile) cat(\n\n, file = thefile) cat(The below is additional metadata, not part of the BIL/HDR format\n, file = thefile) cat(----------------------------------------------------------------\n, file = thefile) cat(CREATOR=R package:x\n, file = thefile) cat(CREATED=, format(Sys.time(), %Y-%m-%d %H:%M:%S), \n, file = thefile) cat(Projection=, projection(x), \n, file = thefile) cat(MinValue=, minValue(x), \n, file = thefile) cat(MaxValue=, maxValue(x), \n, file = thefile) close(thefile) return(invisible(TRUE)) }
115 hdrBov.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : December 2009 # Version 0.9 # Licence GPL v3 .writeHdrBOV <- function(raster) { hdrfile <- filename(raster) extension(hdrfile) <- '.bov' thefile <- file(hdrfile, w) # open an txt file connectionis cat(TIME: 1.23456, \n, file = thefile) datf <- filename(raster) extension(datf) <- '.gri' cat(DATA_FILE:, datf, \n, file = thefile) cat(DATA_SIZE:, nrow(raster), ncol(raster), nlayers(raster), \n, file = thefile) dtype <- substr(raster@file@datanotation, 1, 3) if (dtype == 'INT' | dtype == 'LOG' ) { pixtype <- INT } else { pixtype <- FLOAT } cat(DATA_FORMAT:, pixtype, \n, file = thefile) cat(VARIABLE: , basename(filename(raster)), \n, file = thefile) cat(BYTEORDER , toupper(.Platform$endian), \n, file = thefile) cat(CENTERING: zonal, \n, file = thefile) cat(BRICK_ORIGIN:, xmin(raster), ymin(raster), 0., \n, file = thefile) cat(BRICK_SIZE:, xres(raster), yres(raster), 1., \n, file = thefile) close(thefile) return(invisible(TRUE)) }
116 hdrEnvi.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrENVI <- function(r) { hdrfile <- filename(r) extension(hdrfile) <- .hdr thefile <- file(hdrfile, w) cat(ENVI\n, file = thefile) cat(description = {, names(r), }, \n, file = thefile) cat(samples = , ncol(r), \n, file = thefile) cat(lines = , nrow(r), \n, file = thefile) cat(bands = , r@file@nbands, \n, file = thefile) cat(header offset = 0\n, file = thefile) cat(file type = ENVI Standard\n, file = thefile) dsize <- dataSize(r@file@datanotation) if (.shortDataType(r@file@datanotation) == 'INT') { if (dsize == 1) { dtype <- 1 } else if (dsize == 2) { dtype <- 2 } else if (dsize == 4) { dtype <- 3 } else if (dsize == 8) { dtype <- 14 } else { stop('what?') } } else { if (dsize == 4) { dtype <- 4 } else if (dsize == 8) { dtype <- 5 } else { stop('what?') } } cat(data type = , dtype, \n, file = thefile) #1=8-bit byte; 2=16-bit signed integer; 3=32-bit signed long integer; 4=32-bit floating point; #5=64-bit double-precision floating point; 6=2x32-bit complex, real-imaginary pair of double precision; #9=2x64-bit double-precision complex, real-imaginary pair of double precision; 12=16-bit unsigned integer; #13=32-bit unsigned long integer; 14=64-bit signed long integer; and 15=64-bit unsigned long integer. cat(interleave = , r@file@bandorder, \n, file = thefile) cat(sensor type = \n, file = thefile) btorder <- as.integer(r@file@byteorder != 'little') # little -> 0, big -> 1 cat(byte order = , btorder, \n,file = thefile) if (couldBeLonLat(r)) { cat(map info = {Geographic Lat/Lon, 1, 1,, xmin(r),, , ymax(r),, , xres(r),, , yres(r), }\n, file = thefile) } else { cat(map info = {projection, 1, 1,, xmin(r),, , ymax(r),, , xres(r),, , yres(r), }\n, file = thefile) } if (.requireRgdal(FALSE)) { cat(coordinate system string = {, rgdal::showWKT(projection(r)), }\n, file = thefile, sep=) } else { cat(projection info =, projection(r), \n, file = thefile) } cat(z plot range = {, minValue(r),, , maxValue(r), }\n, file = thefile) close(thefile) }
117 hdrErdasRaw.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 .writeHdrErdasRaw <- function(raster) { hdrfile <- filename(raster) extension(hdrfile) <- .raw thefile <- file(hdrfile, w) # open an txt file connectionis cat(IMAGINE_RAW_FILE\n, file = thefile) cat(PIXEL_FILES , .setFileExtensionValues(raster@file@name), \n, file = thefile) # this may not work. Some implementations may ignore this keyword and expect the pixelfile to have the same file name, no extension. cat(HEIGHT , nrow(raster), \n, file = thefile) cat(WIDTH , ncol(raster), \n, file = thefile) cat(NUM_LAYERS , nbands(raster), \n, file = thefile) if (.shortDataType(raster@file@datanotation) == 'INT') { dd <- S } else { dd <- F } nbits <- dataSize(raster@file@datanotation) * 8 dtype <- paste(dd, nbits, sep=) cat(DATA_TYPE , dtype, \n, file = thefile) #U1, U2, U4, U8, U16, U32 #S16, S32 #F32, and F64. if (.Platform$endian == little) { btorder <- LSB } else { btorder <- MSB } cat(BYTE_ORDER , btorder, \n, file = thefile) #Required for DATA_TYPE values of U16, S16, U32, S32 cat(FORMAT , BIL, \n, file = thefile) cat(DATA_OFFSET 0\n, file = thefile) cat(END_RAW_FILE\n, file = thefile) cat(\n\n, file = thefile) cat(The below is additional metadata, not part of the ERDAS raw format\n, file = thefile) cat(----------------------------------------------------------------\n, file = thefile) cat(CREATOR=R package:raster\n, file = thefile) cat(CREATED=, format(Sys.time(), %Y-%m-%d %H:%M:%S), \n, file = thefile) cat(Projection=, projection(raster), \n, file = thefile) cat(MinValue=, minValue(raster), \n, file = thefile) cat(MaxValue=, maxValue(raster), \n, file = thefile) close(thefile) .worldFile(raster, .rww) }
118 hdrIDRISI.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrIDRISI <- function(x, old=FALSE) { hdrfile <- filename(x) hdrfile <- .setFileExtensionHeader(hdrfile, 'IDRISI') dtype <- .shortDataType(x@file@datanotation) dsize <- dataSize(x) if (dataType(x) == 'INT1U') { pixtype <- 'byte' } else if (dataType(x) == 'INT2S') { pixtype <- 'integer' } else { pixtype <- 'real' } if (couldBeLonLat(x)) { refsystem <- 'latlong' refunits <- 'degrees'; } else { refsystem <- 'plane'; refunits <- 'm'; } thefile <- file(hdrfile, w) # open an txt file connectionis if (!old) cat('file format : IDRISI Raster A.1\n', file = thefile) cat('file title : ', names(x), \n, sep='', file = thefile) cat('data type : ', pixtype, \n, sep='', file = thefile) cat('file type : binary\n', sep='', file = thefile) cat('columns : ', ncol(x), \n, sep='', file = thefile) cat('rows : ', nrow(x), \n, sep='', file = thefile) cat('ref. system : ', refsystem, \n, sep='', file = thefile) cat('ref. units : ', refunits, \n, sep='', file = thefile) cat('unit dist. : 1.0000000', \n, sep='', file = thefile) cat('min. X : ', as.character(xmin(x)), \n, sep='', file = thefile) cat('max. X : ', as.character(xmax(x)), \n, sep='', file = thefile) cat('min. Y : ', as.character(ymin(x)), \n, sep='', file = thefile) cat('max. Y : ', as.character(ymax(x)), \n, sep='', file = thefile) cat(pos'n error : unknown\n, file = thefile) cat('resolution : ', xres(x), \n, sep='', file = thefile) cat('min. value : ', minValue(x), \n, sep='', file = thefile) cat('max. value : ', maxValue(x), \n, sep='', file = thefile) if (!old) cat('display min : ', minValue(x), \n, sep='', file = thefile) if (!old) cat('display max : ', maxValue(x), \n, sep='', file = thefile) cat('value units : unspecified\n', file = thefile) cat('value error : unknown\n', file = thefile) cat('flag value : ', .nodatavalue(x), \n, sep='', file = thefile) cat(flag def'n : no data\n, file = thefile) cat('legend cats : 0\n', file = thefile) close(thefile) return(invisible(TRUE)) }
119 hdrPRJ.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : April 2011 # Version 1.0 # Licence GPL v3 .writeHdrPRJ <- function(x, ESRI=TRUE) { .requireRgdal() p4s <- try( rgdal::showWKT(projection(x), file = NULL, morphToESRI = ESRI) ) if (class(p4s) != 'try-error') { prjfile <- filename(x) extension(prjfile) <- '.prj' cat(p4s, file=filename) } else { return(FALSE) } return(invisible(TRUE)) }
120 hdr.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 hdr <- function(x, format, extension='.wld') { if (inherits(x, 'RasterStack')) { stop('Only applicable to RasterLayer and RasterBrick classes (and their derivatives)') } if (x@file@name == '') { stop('Object has no filename') } # if (missing(filename)) { # if (x@file@name == '') { # stop('Object has no filename; please provide a filename= argument') # } # } else { # fn <- trim(as.character(filename[1])) # if (nchar(fn) < 1) { # stop('invalid filename') # } # x@file@name == fn # } type <- toupper(format) if (type==RASTER) { .writeHdrRaster(x) } else if (type==WORLDFILE) { .worldFile(x, extension) } else if (type==VRT) { .writeHdrVRT(x) .writeStx(x) } else if (type==BIL) { .writeHdrBIL(x) .writeStx(x) } else if (type==BSQ) { .writeHdrBIL(x, BSQ) .writeStx(x) } else if (type==BIP) { .writeHdrBIL(x, BIP) .writeStx(x) } else if (type==ERDASRAW) { .writeHdrErdasRaw(x) .writeStx(x) } else if (type==ENVI) { .writeHdrENVI(x) .writeStx(x) } else if (type==SAGA) { .writeHdrSAGA(x) } else if (type==IDRISI) { .writeHdrIDRISI(x) } else if (type==IDRISIold) { .writeHdrIDRISI(x, old=TRUE) } else if (type==PRJ) { .writeHdrPRJ(x, ESRI=TRUE) } else { stop(This file format is not supported) } return( invisible(TRUE) ) } .writeStx <- function(x, filename='') { if (x@data@haveminmax) { if (filename=='') { filename <- filename(x) } if (filename!='') { extension(filename) <- .stx thefile <- file(filename, w) # open a txt file connectionis cat(1, , minValue(x), , maxValue(x), \n, file = thefile) close(thefile) } } return( invisible(TRUE) ) }
121 hdrRaster.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .writeHdrRaster <- function(x, type='raster') { rastergrd <- .setFileExtensionHeader(filename(x), type) thefile <- file(rastergrd, w) # open an txt file connection cat([general], \n, file = thefile) cat(creator=R package 'raster', \n, file = thefile) cat(created=, format(Sys.time(), %Y-%m-%d %H:%M:%S), \n, file = thefile) cat([georeference], \n, file = thefile) cat(nrows=, nrow(x), \n, file = thefile) cat(ncols=, ncol(x), \n, file = thefile) cat(xmin=, as.character(xmin(x)), \n, file = thefile) cat(ymin=, as.character(ymin(x)), \n, file = thefile) cat(xmax=, as.character(xmax(x)), \n, file = thefile) cat(ymax=, as.character(ymax(x)), \n, file = thefile) cat(projection=, projection(x), \n, file = thefile) cat([data], \n, file = thefile) cat(datatype=, x@file@datanotation, \n, file = thefile) cat(byteorder=, x@file@byteorder, \n, file = thefile) nl <- nlayers(x) cat(nbands=, nl, \n, file = thefile) cat(bandorder=, x@file@bandorder, \n, file = thefile) # currently only for single layer files! if (nl == 1) { fact <- is.factor(x)[1] cat(categorical=, paste(fact, collapse=':'), \n, file = thefile) if (any(fact)) { r <- x@data@attributes[[1]] cat(ratnames=, paste(colnames(r), collapse=':'), \n, file = thefile) cat(rattypes=, paste(sapply(r, class), collapse=':'), \n, file = thefile) cat(ratvalues=, paste(trim(as.character(as.matrix(r))), collapse=':'), \n, file = thefile) } } # cat(levels=, x@data@levels, \n, file = thefile) cat(minvalue=, paste(minValue(x, -1, warn=FALSE), collapse=':'), \n, file = thefile) cat(maxvalue=, paste(maxValue(x, -1, warn=FALSE), collapse=':'), \n, file = thefile) cat(nodatavalue=, .nodatavalue(x), \n, file = thefile) # cat(Sparse=, x@sparse, \n, file = thefile) # cat(nCellvals=, x@data@ncellvals, \n, file = thefile) cat([legend], \n, file = thefile) cat(legendtype=, x@legend@type, \n, file = thefile) cat(values=, paste(x@legend@values, collapse=':'), \n, file = thefile) cat(color=, paste(x@legend@color, collapse=':'), \n, file = thefile) cat([description], \n, file = thefile) ln <- gsub(:, ., names(x)) cat(layername=, paste(ln, collapse=':'), \n, file = thefile) z <- getZ(x) if (! is.null(z)) { zname <- names(x@z)[1] if (is.null(zname)) { zname <- 'z-value' } zclass <- class(z) z <- as.character(z) cat(zvalues=, paste(c(zname, z), collapse=':'), \n, file = thefile) cat(zclass=, zclass, \n, file = thefile) } a <- NULL try( a <- unlist(x@history), silent=TRUE ) if (!is.null(a)) { cat(history=, a, \n, file = thefile) } a <- NULL try( a <- rapply(x@history, function(x) paste(as.character(x), collapse='#,#')), silent=TRUE ) if (!is.null(a)) { a <- gsub('\n', '#NL#', a) type <- rapply(x@history, class) type_value <- apply(cbind(type, a), 1, function(x) paste(x, collapse=':')) name_type_value <- apply(cbind(names(a), type_value), 1, function(x) paste(x, collapse='=')) name_type_value <- paste(name_type_value, '\n', sep='') cat([metadata], \n, file = thefile) cat(name_type_value, file = thefile) } close(thefile) return(TRUE) }
122 hdrSAGA.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrSAGA <- function(x) { hdrfile <- filename(x) hdrfile <- .setFileExtensionHeader(hdrfile, 'SAGA') thefile <- file(hdrfile, w) # open an txt file connectionis cat(NAME\t=, names(x), \n, file = thefile) cat(DESCRIPTION\t= \n, file = thefile) cat(UNIT\t= \n, file = thefile) dtype <- .shortDataType(x@file@datanotation) dsize <- dataSize(x@file@datanotation) if (dtype == 'INT' ) { if (dsize == 1) { pixtype <- BYTE } else if (dsize == 2) { pixtype <- SHORTINT } else if (dsize == 4) { pixtype <- INTEGER } if (! dataSigned(x@file@datanotation)) { pixtype <- paste(pixtype, _UNSIGNED, sep=) } } else if ( x@file@datanotation == 'FLT4S' ) { pixtype <- FLOAT } else { stop(paste('cannot write SAGA file with data type:', x@file@datanotation)) } cat(DATAFORMAT\t=, pixtype, \n, file = thefile) cat(DATAFILE_OFFSET\t= 0\n, file = thefile) cat(BYTEORDER_BIG\t=, x@file@byteorder != 'little', \n, file = thefile) cat(POSITION_XMIN\t= , as.character(xmin(x) + 0.5 * xres(x)), \n, file = thefile) cat(POSITION_YMIN\t= , as.character(ymin(x) + 0.5 * yres(x)), \n, file = thefile) cat(CELLCOUNT_Y\t= , nrow(x), \n, file = thefile) cat(CELLCOUNT_X\t= , ncol(x), \n, file = thefile) cat(CELLSIZE\t= , xres(x), \n, file = thefile) cat(Z_FACTOR\t= 1.000000\n, file = thefile) cat(NODATA_VALUE\t=, .nodatavalue(x), \n, file = thefile) cat(TOPTOBOTTOM\t= TRUE, \n, file = thefile) close(thefile) return(invisible(TRUE)) }
123 hdrVRT.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2010 # Version 1.0 # Licence GPL v3 .writeHdrVRT <- function(x) { fn <- fname <- x@file@name if (tolower(extension(fn)) == '.vrt') { stop('cannot (over)write a vrt header for a vrt file') } if (tolower(extension(fn)) == '.grd') { extension(fn) <- '.gri' } extension(fname) <- 'vrt' pixsize <- dataSize(x@file@datanotation) nbands <- nlayers(x) bandorder <- x@file@bandorder if (bandorder == 'BIL') { pixoff <- pixsize lineoff <- pixsize * x@ncols * nbands imgoff <- ((1:nbands)-1) * x@ncols * pixsize } else if (bandorder == 'BSQ') { pixoff <- pixsize lineoff <- pixsize * x@ncols imgoff <- ((1:nbands)-1) * ncell(x) * pixsize } else if (bandorder == 'BIP') { pixoff <- pixsize * nbands lineoff <- pixsize * x@ncols * nbands imgoff <- (1:nbands)-1 } datatype <- .getGdalDType(x@file@datanotation) if (x@file@byteorder == little) { byteorder <- LSB } else { byteorder <- MSB } if (! x@file@toptobottom) { rotation <- 180 } else { rotation <- 0 } e <- x@extent r <- res(x) prj <- projection(x) f <- file(fname, w) cat('<VRTDataset rasterXSize=', x@ncols, ' rasterYSize=', x@nrows, '>\n' , sep = , file = f) if (rotated(r)) { cat('<GeoTransform>', paste(x@rotation@geotrans, collapse=', '), '</GeoTransform>\n', sep = , file = f) } else { cat('<GeoTransform>', e@xmin, ', ', r[1], ', ', rotation, ', ', e@ymax, ', ', 0.0, ', ', -1*r[2], '</GeoTransform>\n', sep = , file = f) } if (! is.na(prj) ) { cat('<SRS>', prj ,'</SRS>\n', sep = , file = f) } for (i in 1:nlayers(x)) { cat('\t<VRTRasterBand dataType=', datatype, ' band=', i, ' subClass=VRTRawRasterBand>\n', sep = , file = f) cat('\t\t<Description>', names(x), '</Description>\n', sep = , file = f) cat('\t\t<SourceFilename relativetoVRT=1>', basename(fn), '</SourceFilename>\n', sep = , file = f) cat('\t\t<ImageOffset>', imgoff[i], '</ImageOffset>\n', sep = , file = f) cat('\t\t<PixelOffset>', pixoff, '</PixelOffset>\n', sep = , file = f) cat('\t\t<LineOffset>', lineoff, '</LineOffset>\n', sep = , file = f) cat('\t\t<ByteOrder>', byteorder, '</ByteOrder>\n', sep = , file = f) cat('\t\t<NoDataValue>', x@file@nodatavalue, '</NoDataValue>\n', sep = , file = f) cat('\t\t<Offset>', x@data@offset, '</Offset>\n', sep = , file = f) cat('\t\t<Scale>', x@data@gain, '</Scale>\n', sep = , file = f) cat('\t</VRTRasterBand>\n', sep = , file = f) } cat('</VRTDataset>\n', sep = , file = f) close(f) return( invisible(TRUE) ) }
124 hdrWorldFile.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 .worldFile <- function(raster, extension=.wld) { hdrfile <- filename(raster) extension(hdrfile) <- extension thefile <- file(hdrfile, w) cat(as.character(xres(raster)), \n, file = thefile) cat(0\n, file = thefile) cat(0\n, file = thefile) cat(-1 * yres(raster), \n, file = thefile) cat(xmin(raster) + 0.5 * xres(raster), \n, file = thefile) cat(ymax(raster) - 0.5 * yres(raster), \n, file = thefile) close(thefile) }
125 head.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : December 2010 # Version 0.9 # Licence GPL v3 if (!isGeneric(head)) { setGeneric(head, function(x, ...) standardGeneric(head)) } if (!isGeneric(tail)) { setGeneric(tail, function(x, ...) standardGeneric(tail)) } setMethod('head', signature(x='RasterLayer'), function(x, cols=20, rows=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) v <- getValuesBlock(x, 1, nrows=nr, ncols=nc, format='matrix') return(v) } ) setMethod('tail', signature(x='RasterLayer'), function(x, cols=20, rows=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) sr <- x@nrows - nr + 1 sc <- x@ncols - nc + 1 v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc, format='matrix') return(v) } ) setMethod('head', signature(x='RasterStackBrick'), function(x, cols=10, rows=2, layers=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) nl <- min(nlayers(x), max(1, layers)) v <- getValuesBlock(x, 1, nrows=nr, ncols=nc) return(v) } ) setMethod('tail', signature(x='RasterStackBrick'), function(x, cols=10, rows=2, layers=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) nl <- min(nlayers(x), max(1, layers)) sr <- x@nrows - nr + 1 sc <- x@ncols - nc + 1 v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc) return(v) } ) setMethod('head', signature(x='Spatial'), function(x, n=6L,...) { if (.hasSlot(x, 'data')) { head(x@data, n=n, ...) } else { x[1,] } } ) setMethod('tail', signature(x='Spatial'), function(x, n=6L, ...) { if (.hasSlot(x, 'data')) { tail(x@data, n=n, ...) } else { x[length(x),] } } )
126 hillShade.R
# Author: Andrew Bevan, Oscar Perpiñán Lamigueiro, and Robert J. Hijmans # Date : March 2010 # Version 1.0 # Licence GPL v3 hillShade <- function(slope, aspect, angle=45, direction=0, filename='', normalize=FALSE, ...) { compareRaster(slope, aspect) direction <- direction * pi/180 zenith <- (90 - angle)*pi/180 #x <- cos(slope) * cos(declination) + sin(slope) * sin(declination) * cos(direction-aspect) if (normalize) { fun <- function(slp, asp) { shade <- cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) shade[shade < 0] <- 0 shade * 255 } } else { fun <- function(slp, asp) { cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) } } x <- overlay(slope, aspect, fun=fun, filename=filename, ...) return(x) }
127 hist.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod('hist', signature(x='Raster'), function(x, layer, maxpixels=100000, plot=TRUE, main, ...) { if (missing(layer)) { y <- 1:nlayers(x) } else if (is.character(layer)) { y <- match(layer, names(x)) } else { y <- layer } y <- unique(as.integer(round(y))) y <- na.omit(y) y <- y[ y >= 1 & y <= nlayers(x) ] nl <- length(y) if (nl == 0) { stop('no layers selected') } if (missing(main)) { main=names(x) } if (nl > 1) { res <- list() if (nl > 16) { warning('only the first 16 layers are plotted') nl <- 16 y <- y[1:16] } nc <- ceiling(sqrt(nl)) nr <- ceiling(nl / nc) mfrow <- par(mfrow) spots <- mfrow[1] * mfrow[2] if (spots < nl) { par(mfrow=c(nr, nc)) } for (i in 1:length(y)) { res[[i]] = .hist1(raster(x, y[i]), maxpixels=maxpixels, main=main[y[i]], plot=plot, ...) } } else if (nl==1) { if (nlayers(x) > 1) { x <- x[[y]] main <- main[y] } res <- .hist1(x, maxpixels=maxpixels, main=main, plot=plot, ...) } if (plot) { return(invisible(res)) } else { return(res) } } ) .hist1 <- function(x, maxpixels, main, plot, ...){ if ( inMemory(x) ) { v <- getValues(x) } else if ( fromDisk(x) ) { if (ncell(x) <= maxpixels) { v <- na.omit(getValues(x)) } else { # TO DO: make a function that does this by block and combines all data into a single histogram v <- sampleRandom(x, maxpixels) msg <- paste(round(100 * maxpixels / ncell(x)), % of the raster cells were used, sep=) if (maxpixels > length(v)) { msg <- paste(msg, (of which , 100 - round(100 * length(v) / maxpixels ), % were NA), sep=) } warning( paste(msg, . ,length(v), values used., sep=) ) } } else { stop('cannot make a histogram; need data on disk or in memory') } if (.shortDataType(x) == 'LOG') { v <- v * 1 } if (plot) { hist(v, main=main, plot=plot, ...) } else { hist(v, plot=plot, ...) } }
128 idwValue.R
# Author: Robert J. Hijmans # Date : November 2009 # Version 1.0 # Licence GPL v3 # under development ..idwValue <- function(raster, xy, ngb=4, pow=1, layer, n) { r <- raster(raster) longlat <- couldBeLonLat(r) cells <- cellFromXY(r, xy) adj <- adjacent(r, cells, ngb, pairs=TRUE, include=TRUE, id=TRUE) uc <- unique(adj[,3]) row1 <- rowFromCell(r, min(uc, na.rm=TRUE)) nrows <- row1 - 1 + rowFromCell(r, max(uc, na.rm=TRUE)) offs <- cellFromRowCol(r, row1, 1) - 1 cs <- uc - offs nl <- nlayers(raster) if (nl==1) { v <- cbind(uc, v=getValues(raster, row1, nrows)[cs]) } else { v <- cbind(uc, v=getValues(raster, row1, nrows)[cs,]) } m <- merge(adj, v, by.x='to', by.y=1) colnames(xy) <- c('x', 'y') m <- merge(m, cbind(1:nrow(xy), xy), by.x='id', by.y=1) pd <- pointDistance(m[,c('x', 'y')], xyFromCell(r, m$to), lonlat=longlat) / 1000 pd <- pd^pow pd[pd==0] <- 1e-12 if (nl==1) { pd[is.na(m$v)] <- NA as.vector( tapply(m$v*(1/pd), m$id, sum, na.rm=TRUE) / tapply(1/pd, m$id, sum, na.rm=TRUE) ) #cbind(as.integer(names(res)), res) } else { lys <- 4:(4+nl-1) a1 <- aggregate(m[,lys]*(1/pd), list(m$id), sum) a2 <- aggregate(1/pd, list(m$id), sum) res <- as.matrix(a1[,-1]) / as.vector(as.matrix(a2[,-1])) res <- cbind(as.vector(a1[,1]), res) res[, -1] } } #a=raster(nc=10,nr=10) #xmin(a)=55 #projection(a) = +proj=utm +zone=33 #a[] = 1:ncell(a) #a[50:75]=NA #r = disaggregate(raster(a), 3) #r[] = .idwValue(a, coordinates(r)) #plot(r)
129 imageplot2.R
# The functions is based on a function in the fields package # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html # # Adjustments by Robert Hijmans # July 2011 .asRaster <- function(x, col, breaks=NULL, r=NULL, colNA=NA) { if (!is.null(breaks)) { if (is.logical(x)) { x <- x * 1 } x[] <- as.numeric(cut(as.vector(x), breaks, include.lowest=TRUE)) } else { #if (is.function(fun)) { # x[] <- fun(x) #} if (is.null(r)) { r <- range(x, na.rm=TRUE) } if (r[1] == r[2]) { r[1] <- r[1] - 0.001 r[2] <- r[2] + 0.001 } x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) } x[] <- col[x] if (!is.na(colNA)) { x[is.na(x)] <- rgb(t(col2rgb(colNA)), maxColorValue=255) } as.raster(x) } .rasterImagePlot <- function(x, col, add=FALSE, legend=TRUE, horizontal = FALSE, legend.shrink=0.5, legend.width=0.6, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab=NULL, graphics.reset=FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, lab.breaks=NULL, axis.args=NULL, legend.args = NULL, interpolate=FALSE, box=TRUE, breaks=NULL, zlim=NULL, zlimcol=NULL, fun=NULL, asp, colNA = NA, ...) { ffun <- NULL if (is.character(fun)) { if (fun %in% c('sqrt', 'log')) { if (fun == 'sqrt') { ffun <- fun fun <- sqrt } else { ffun <- fun fun <- log } } else { fun - NULL } } else { fun <- NULL } if (missing(asp)) { if (couldBeLonLat(x, warnings=FALSE)) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) } else { asp <- 1 } } e <- as.vector(t(bbox(extent(x)))) x <- as.matrix(x) if (!is.null(fun)) { x <- fun(x) } x[is.infinite(x)] <- NA if (!is.null(zlim)) { if (!is.null(zlimcol)) { x[x < zlim[1]] <- zlim[1] x[x > zlim[2]] <- zlim[2] } else { #if (is.na(zlimcol)) { x[x < zlim[1] | x > zlim[2]] <- NA } } w <- getOption('warn') options('warn'=-1) if (is.null(breaks)) { zrange <- range(x, zlim, na.rm=TRUE) } else { zrange <- range(x, zlim, breaks, na.rm=TRUE) } options('warn'=w) if (! is.finite(zrange[1])) { legend <- FALSE } else { x <- .asRaster(x, col, breaks, zrange, colNA) } old.par <- par(no.readonly = TRUE) if (add) { big.plot <- old.par$plt } if (legend.only) { graphics.reset <- TRUE } if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, horizontal = horizontal, bigplot = bigplot, smallplot = smallplot) smallplot <- temp$smallplot bigplot <- temp$bigplot if (legend.only) { box <- FALSE } else { if (!add) { par(plt = bigplot) plot(NA, NA, xlim=e[1:2], ylim=e[3:4], type = n, , xaxs ='i', yaxs = 'i', asp=asp, ...) } rasterImage(x, e[1], e[3], e[2], e[4], interpolate=interpolate) big.par <- par(no.readonly = TRUE) } if (legend) { if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) { par(old.par) stop(plot region is too small. Cannot add a legend\n) } ix <- 1 minz <- zrange[1] maxz <- zrange[2] if (minz == maxz) { if (!is.null(breaks)) { breaks=minz } else { minz <- minz - 0.001 maxz <- maxz + 0.001 } } par(new=TRUE, pty = m, plt=smallplot, err = -1) if (!is.null(breaks)) { binwidth <- (maxz - minz)/100 midpoints <- seq(minz, maxz, by = binwidth) axis.args <- c(list(side=ifelse(horizontal,1,4), mgp=c(3,1,0), las=ifelse(horizontal,0,2)), axis.args) if (is.null(axis.args$at)) { axis.args$at <- breaks } if (is.null(axis.args$labels) ) { axis.args$labels=lab.breaks } } else { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args) } if (!horizontal) { plot(NA, NA, xlim=c(0, 1), ylim=c(minz, maxz), type=n, xlab=, ylab=, xaxs ='i', yaxs = 'i', axes=FALSE) if (is.null(breaks)) { mult <- round(max(1, 100 / length(col) )) xx <- .asRaster( ((mult*length(col)):1)/mult, col, colNA=colNA) } else { xx <- rev(.asRaster(midpoints, col, breaks=breaks, colNA=colNA)) } rasterImage(xx, 0, minz, 1, maxz, interpolate=FALSE) if (!is.null(ffun)) { at <- axTicks(2) axis.args$at <- at if (ffun=='sqrt') { at <- at^2 if (max(at) > 5) { at <- round(at, 0) } else { at <- round(at, 1) } at <- unique(at) axis.args$at <- sqrt(at) } else { at <- exp(at) if (max(at) > 5) { at <- round(at, 0) } else { at <- round(at, 1) } at <- unique(at) axis.args$at <- log(at) } axis.args$labels <- at } do.call(axis, axis.args) box() } else { plot(NA, NA, ylim=c(0, 1), xlim=c(minz, maxz), type=n, xlab=, ylab=, xaxs ='i', yaxs = 'i', axes=FALSE) if (is.null(breaks)) { mult <- round(max(1, 100 / length(col) )) xx <- t(.asRaster((1:(mult*length(col)))/mult, col, colNA=colNA )) } else { xx <- t(.asRaster(midpoints, col, breaks=breaks, colNA=colNA)) } rasterImage(xx, minz, 0, maxz, 1, interpolate=FALSE) do.call(axis, axis.args) box() } if (!is.null(legend.lab)) { legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) } if (!is.null(legend.args)) { do.call(mtext, legend.args) } } mfg.save <- par()$mfg if (graphics.reset | add) { par(old.par) par(mfg = mfg.save, new = FALSE) } else { par(big.par) par(plt = big.par$plt, xpd = FALSE) par(mfg = mfg.save, new = FALSE) } if (!add & box ) box() invisible() }
130 imageplot.R
# The functions below here were taken from the fields package !!! (image.plot and subroutines) # to be adjusted for the RasterLayer object. # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html .imageplot <- function (x, y, z, add=FALSE, legend=TRUE, nlevel = 64, horizontal = FALSE, # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html legend.shrink = 0.5, legend.width = 0.6, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL, graphics.reset = FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, col = heat.colors(nlevel), lab.breaks = NULL, axis.args = NULL, legend.args = NULL, midpoint = FALSE, box=TRUE, useRaster=FALSE, ...) { zlim <- range(z, na.rm = TRUE) old.par <- par(no.readonly = TRUE) if (add) { big.plot <- old.par$plt } if (legend.only) { graphics.reset <- TRUE } if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, horizontal = horizontal, bigplot = bigplot, smallplot = smallplot) smallplot <- temp$smallplot bigplot <- temp$bigplot if (!legend.only) { if (!add) { par(plt = bigplot) } if (R.Version()$minor >= 13) { image(x, y, z, add = add, col = col, useRaster=useRaster, ...) } else { image(x, y, z, add = add, col = col, ...) } big.par <- par(no.readonly = TRUE) } else { box <- FALSE } if (legend) { if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) { par(old.par) stop(plot region too small to add legend\n) } ix <- 1 minz <- zlim[1] maxz <- zlim[2] binwidth <- (maxz - minz)/nlevel midpoints <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth) iy <- midpoints iz <- matrix(iy, nrow = 1, ncol = length(iy)) breaks <- list(...)$breaks par(new=TRUE, pty = m, plt=smallplot, err = -1) if (!is.null(breaks)) { if (is.null(lab.breaks)) { lab.breaks <- as.character(breaks) } axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args) } else { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args) } if (!horizontal) { if (is.null(breaks)) { if (R.Version()$minor >= 13) { image(ix, iy, iz, xaxt=n, yaxt=n, xlab=, ylab=, col=col, useRaster=useRaster) } else { image(ix, iy, iz, xaxt=n, yaxt=n, xlab=, ylab=, col=col) } } else { if (R.Version()$minor >= 13) { image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col=col, breaks=breaks, useRaster=useRaster) } else { image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col=col, breaks=breaks) } } } else { if (is.null(breaks)) { if (R.Version()$minor >= 13) { image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, useRaster=useRaster) } else { image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col) } } else { if (R.Version()$minor >= 13) { image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, breaks = breaks, useRaster=useRaster) } else { image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, breaks = breaks) } } } do.call(axis, axis.args) box() if (!is.null(legend.lab)) { legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) } if (!is.null(legend.args)) { do.call(mtext, legend.args) } } mfg.save <- par()$mfg if (graphics.reset | add) { par(old.par) par(mfg = mfg.save, new = FALSE) } else { par(big.par) par(plt = big.par$plt, xpd = FALSE) par(mfg = mfg.save, new = FALSE) } if (!add & box ) box() invisible() } .polyimage <- function (x, y, z, col = heat.colors(64), transparent.color = white, # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html midpoint = FALSE, zlim = range(z, na.rm = TRUE), xlim = range(x), ylim = range(y), add = FALSE, border = NA, ...) { polyimageregrid <- function (x) { temp.addcol <- function(X) { N <- ncol(X) cbind(X[, 1] - (X[, 2] - X[, 1]), X, (X[, N] - X[, (N - 1)]) + X[, N]) } M <- nrow(x) N <- ncol(x) x <- (x[, 1:(N - 1)] + x[, 2:N])/2 x <- (x[1:(M - 1), ] + x[2:M, ])/2 x <- t(temp.addcol(x)) t(temp.addcol(x)) } drapecolor <- function (z, col = heat.colors(64), zlim = NULL, transparent.color = white, midpoint = TRUE) { eps <- 1e-07 if (is.null(zlim)) { zlim <- range(c(z), na.rm = TRUE) } z[(z < zlim[1]) | (z > zlim[2])] <- NA NC <- length(col) M <- nrow(z) N <- ncol(z) if (midpoint) { z <- (z[1:(M - 1), 1:(N - 1)] + z[2:M, 1:(N - 1)] + z[1:(M - 1), 2:N] + z[2:M, 2:N])/4 } dz <- (zlim[2] * (1 + eps) - zlim[1])/NC zcol <- floor((z - zlim[1])/dz + 1) ifelse(zcol > NC, transparent.color, col[zcol]) } Dx <- dim(x) Dy <- dim(y) if (any((Dx - Dy) != 0)) { stop( x and y matrices should have same dimensions) } Dz <- dim(z) if (all((Dx - Dz) == 0) & !midpoint) { x <- polyimageregrid(x) y <- polyimageregrid(y) } zcol <- drapecolor(z, col = col, midpoint = midpoint, zlim = zlim, transparent.color = transparent.color) if (!add) { plot(xlim, ylim, type = n, ...) } N <- ncol(x) Nm1 <- N - 1 M <- nrow(x) Mm1 <- M - 1 for (i in (1:Mm1)) { xp <- cbind(x[i, 1:Nm1], x[i + 1, 1:Nm1], x[i + 1, 2:N], x[i, 2:N], rep(NA, Nm1)) yp <- cbind(y[i, 1:Nm1], y[i + 1, 1:Nm1], y[i + 1, 2:N], y[i, 2:N], rep(NA, Nm1)) xp <- c(t(xp)) yp <- c(t(yp)) polygon(xp, yp, border = NA, col = c(zcol[i, 1:Nm1])) } } .imageplotplt <- function (x, add = FALSE, legend.shrink = 0.9, legend.width = 1, # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html horizontal = FALSE, legend.mar = NULL, bigplot = NULL, smallplot = NULL, ...) { old.par <- par(no.readonly = TRUE) if (is.null(smallplot)) stick <- TRUE else stick <- FALSE if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } char.size <- ifelse(horizontal, par()$cin[2]/par()$din[2], par()$cin[1]/par()$din[1]) offset <- char.size * ifelse(horizontal, par()$mar[1], par()$mar[4]) legend.width <- char.size * legend.width legend.mar <- legend.mar * char.size if (is.null(smallplot)) { smallplot <- old.par$plt if (horizontal) { smallplot[3] <- legend.mar smallplot[4] <- legend.width + smallplot[3] pr <- (smallplot[2] - smallplot[1]) * ((1 - legend.shrink)/2) smallplot[1] <- smallplot[1] + pr smallplot[2] <- smallplot[2] - pr } else { smallplot[2] <- 1 - legend.mar smallplot[1] <- smallplot[2] - legend.width pr <- (smallplot[4] - smallplot[3]) * ((1 - legend.shrink)/2) smallplot[4] <- smallplot[4] - pr smallplot[3] <- smallplot[3] + pr } } if (is.null(bigplot)) { bigplot <- old.par$plt if (!horizontal) { bigplot[2] <- min(bigplot[2], smallplot[1] - offset) } else { bottom.space <- old.par$mar[1] * char.size bigplot[3] <- smallplot[4] + offset } } if (stick & (!horizontal)) { dp <- smallplot[2] - smallplot[1] smallplot[1] <- min(bigplot[2] + offset, smallplot[1]) smallplot[2] <- smallplot[1] + dp } return(list(smallplot = smallplot, bigplot = bigplot)) }
131 image.R
# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(image)) { setGeneric(image, function(x,...) standardGeneric(image)) } setMethod(image, signature(x='RasterLayer'), function(x, maxpixels=500000, useRaster=TRUE, ...) { # coltab <- x@legend@colortable # if (is.null(coltab) | length(coltab) == 0 | is.null(list(...)$col)) { # colortab <- FALSE # } # if (missing(main)) { main <- names(x) } x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) y <- yFromRow(x, nrow(x):1) value <- t(as.matrix(x)[nrow(x):1,]) x <- xFromCol(x,1:ncol(x)) # if (colortab) { # image(x=x, y=y, z=value, col=coltab[value], useRaster=useRaster, ...) # } else { image(x=x, y=y, z=value, useRaster=useRaster, ...) # } } ) setMethod(image, signature(x='RasterStackBrick'), function(x, y=1, maxpixels=100000, useRaster=TRUE, main, ...) { y <- round(y) stopifnot(y > 0 & y <= nlayers(x)) x <- raster(x, y) if (missing(main)) { main <- names(x) } image(x, maxpixels=maxpixels, useRaster=useRaster, main=main, ...) } )
132 index.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod([, c(Raster, Spatial, missing), function(x, i, j, ... ,drop=TRUE) { if (inherits(i, 'SpatialPoints')) { i <- coordinates(i) i <- cellFromXY(x, i) .doExtract(x, i, ..., drop=drop) } else { if (drop) { extract(x, i, ...) } else { x <- crop(x, i, ...) rasterize(i, x, mask=TRUE, ...) } } }) setMethod([, c(Raster, RasterLayer, missing), function(x, i, j, ... ,drop=TRUE) { if (! hasValues(i) ) { i <- extent(i) callNextMethod(x, i=i, ..., drop=drop) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { i <- which( as.logical( getValues(i) ) ) .doExtract(x, i, drop=drop) } else { i <- intersect(extent(x), extent(i)) callNextMethod(x, i=i, ..., drop=drop) } }) setMethod([, c(Raster, Extent, missing), function(x, i, j, ... ,drop=TRUE) { if (drop) { return( extract(x, i) ) } else { return( crop(x, i) ) } } ) setMethod([, c(Raster, missing, missing), function(x, i, j, ... ,drop=TRUE) { if (drop) { return(getValues(x)) } else { return(x) } }) setMethod([, c(Raster, numeric, numeric), function(x, i, j, ... ,drop=TRUE) { i <- cellFromRowColCombine(x, i, j) .doExtract(x, i, drop=drop) } ) setMethod([, c(Raster, missing, numeric), function(x, i, j, ... ,drop=TRUE) { j <- cellFromCol(x, j) .doExtract(x, j, drop=drop) }) setMethod([, c(Raster, numeric, missing), function(x, i, j, ... ,drop=TRUE) { theCall <- sys.call(-1) narg <- length(theCall) - length(match.call(call=sys.call(-1))) if (narg > 0) { i <- cellFromRow(x, i) } .doExtract(x, i, drop=drop) }) setMethod([, c(Raster, matrix, missing), function(x, i, j, ... ,drop=TRUE) { if (ncol(i) == 2) { i <- cellFromRowCol(x, i[,1], i[,2]) } else { i <- as.vector(i) } .doExtract(x, i, drop=drop) }) setMethod([, c(Raster, logical, missing), function(x, i, j, ... , drop=TRUE) { theCall <- sys.call(-1) narg <- length(theCall) - length(match.call(call=sys.call(-1))) if (narg > 0) { stop('logical indices are only accepted if only the first index is used') } i <- which(i) .doExtract(x, i, drop=drop) }) .doExtract <- function(x, i, drop) { if (! hasValues(x) ) { stop('no data associated with this Raster object') } if (length(i) < 1) return(NULL) nacount <- sum(is.na(i)) if (nacount > 0) { warning('some indices are invalid (NA returned)') } if (drop) { return( .cellValues(x, i) ) } else { i <- na.omit(i) r <- rasterFromCells(x, i, values=FALSE) newi <- cellFromXY(r, xyFromCell(x, i)) if (nlayers(x) > 1) { r <- brick(r) v <- matrix(NA, nrow=ncell(r), ncol=nlayers(x)) v[newi,] <- .cellValues(x, i) v <- setValues(r, v) return(v) } else { r[newi] <- .cellValues(x, i) return(r) } } }
133 indexReplaceBrick.R
# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setMethod($, Raster, function(x, name) { x[[name]] } ) setMethod($<-, Raster, function(x, name, value) { i <- which(name == names(x))[1] if (is.na(i)) { if (inherits(value, 'Raster')) { names(value) <- name x <- addLayer(x, value) return(x) } else { r <- raster(x) names(r) <- name r[] <- value x <- addLayer(x, r) return(x) } } else { if (inherits(value, 'Raster')) { x[[name]] <- value } else { r <- x[[name]] r[] <- value x[[name]] <- value } return(x) } } ) setMethod([[, Raster, function(x,i,j,...,drop=TRUE) { if ( missing(i)) { stop('you must provide an index') } if (! missing(j)) { warning('second index is ignored') } if (is.numeric(i)) { sgn <- sign(i) sgn[sgn==0] <- 1 if (! all(sgn == 1) ) { if (! all(sgn == -1) ) { stop(only 0's may be mixed with negative subscripts) } else { i <- (1:nlayers(x))[i] } } } subset(x, i, drop=drop) }) setReplaceMethod([[, c(RasterStackBrick, character, missing), function(x, i, j, value) { n <- which(i == names(x))[1] if (is.na(n)) { n <- nlayers(x) + 1 } if (inherits(value, 'Raster')) { names(value) <- i } x[[n]] <- value x } ) setReplaceMethod([[, c(RasterStack, numeric, missing), function(x, i, j, value) { i <- round(i) if (i < 1) { stop('index should be > 0') } nl <- nlayers(x) if (i > nl + 1) { stop('index should be <= nlayers(x)+1') } if (!inherits(value, 'RasterLayer')) { val <- value if (i > nl) { value <- x[[nl]] } else { value <- x[[i]] } value[] <- val } else { compareRaster(x, value) } if (i > nl) { x <- addLayer(x, value) } else { x@layers[[i]] <- value } x } ) setReplaceMethod([[, c(RasterBrick, numeric, missing), function(x, i, j, value) { i <- round(i) if (i < 1) { stop('index should be > 0') } nl <- nlayers(x) if (i > nl + 1) { stop('index should be <= nlayers(x)+1') } if (canProcessInMemory(x)) { if (!inMemory(x)) { x <- readAll(x) } if (inherits(value, 'RasterLayer')) { compareRaster(x, value) x <- setValues(x, getValues(value), i) names(x)[i] <- names(value) } else { val <- value if (i > nl) { value <- getValues(x[[nl]]) } else { value <- getValues(x[[i]]) } # for recycling value[] <- val x <- setValues(x, value, i) } } else { x <- stack(x) x[[i]] <- value } return(x) } ) setReplaceMethod([, c(RasterStackBrick, Raster, missing), function(x, i, j, value) { nl <- nlayers(i) if (! hasValues(i) ) { i <- cellsFromExtent(x, i) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { dims <- dim(i) i <- as.logical(getValues(i)) dim(i) <- c(prod(dims[1:2]), dims[3]) } else { i <- cellsFromExtent(x, i) } if (nl < nlayers(x)) { .replace(x, i, value=value, recycle=nl) } else { .replace(x, i, value=value, recycle=1) } } ) setReplaceMethod([, c(Raster, Extent, missing), function(x, i, j, value) { i <- cellsFromExtent(x, i) .replace(x, i, value=value, recycle=1) } ) setReplaceMethod([, c(Raster, Spatial, missing), function(x, i, j, value) { if (inherits(i, 'SpatialPolygons')) { v <- 1:length(i@polygons) v[] <- value return( .polygonsToRaster(i, x, value=v, fun='last', mask=FALSE, update=TRUE, updateValue=all, silent=TRUE) ) } else if (inherits(i, 'SpatialLines')) { v <- 1:length(i@lines) v[] <- value return( .linesToRaster(i, x, field=v, fun='last', mask=FALSE, update=TRUE, updateValue=all, silent=TRUE) ) } else { # if (inherits(i, 'SpatialPoints')) { i <- cellsFromXY(x, coordinates(i)) return( .replace(x, i, value=value, recycle=1) ) } } ) setReplaceMethod([, c(RasterStackBrick,missing,missing), function(x, i, j, value) { nl <- nlayers(x) if (inherits(x, 'RasterStack')) { x <- brick(x, values=FALSE) } if (is.matrix(value)) { if (all(dim(value) == c(ncell(x), nl))) { x <- try( setValues(x, value)) } else { stop('dimensions of the matrix do not match the Raster* object') } } else { v <- try( matrix(nrow=ncell(x), ncol=nl) ) if (class(x) != 'try-error') { v[] <- value x <- try( setValues(x, v) ) } } if (class(x) == 'try-error') { stop('cannot set values on this raster (it is too large)') } return(x) } ) setReplaceMethod([, c(Raster, numeric, numeric), function(x, i, j, value) { i <- cellFromRowColCombine(x, i, j) .replace(x, i, value, recycle=1) } ) setReplaceMethod([, c(Raster,missing, numeric), function(x, i, j, value) { j <- cellFromCol(x, j) .replace(x, j, value=value, recycle=1) } ) setReplaceMethod([, c(Raster,numeric, missing), function(x, i, j, value) { theCall <- sys.call(-1) narg <- length(theCall)-length(match.call(call=sys.call(-1))) if (narg > 0) { i <- cellFromRow(x, i) } .replace(x, i=i, value=value, recycle=1) } ) setReplaceMethod([, c(Raster, matrix, missing), function(x, i, j, value) { if (ncol(i) == 2) { i <- cellFromRowCol(x, i[,1], i[,2]) } else { i <- as.vector(i) } .replace(x, i=i, value=value, recycle=1) } ) setReplaceMethod([, c(Raster, logical, missing), function(x, i, j, value) { .replace(x, i, value, recycle=1) } )
134 indexReplace.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : January 2009 # Version 1.0 # Licence GPL v3 setReplaceMethod([, c(RasterLayer, RasterLayer, missing), function(x, i, j, value) { if (! hasValues(i) ) { i <- cellsFromExtent(x, i) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { i <- as.logical( getValues(i) ) } else { i <- cellsFromExtent(x, i) } .replace(x, i, value=value, recycle=1) } ) setReplaceMethod([, c(RasterLayer,missing,missing), function(x, i, j, value) { if (length(value) == ncell(x)) { x <- try( setValues(x, value)) } else if (length(value) == 1) { x <- try( setValues(x, rep(value, times=ncell(x))) ) } else { v <- try( vector(length=ncell(x)) ) if (class(x) != 'try-error') { v[] <- value x <- try( setValues(x, v) ) } } if (class(x) == 'try-error') { stop('cannot replace values on this raster (it is too large') } return(x) } ) .replace <- function(x, i, value, recycle=1) { if ( is.logical(i) ) { i <- which(i) } else { # if (! is.numeric(i)) { # i <- as.integer(i) # } i <- na.omit(i) } nl <- nlayers(x) # recycling if (nl > 1) { rec2 <- ceiling(nl / recycle) if (rec2 > 1) { add <- ncell(x)*recycle * (0:(rec2-1)) i <- as.vector(t((matrix(rep(i, rec2), nrow=rec2, byrow=TRUE)) + add)) } } j <- i > 0 & i <= (ncell(x)*nl) if (!all(j)) { i <- i[j] if (length(value) > 1) { value <- value[j] } } if ( inMemory(x) ) { if (inherits(x, 'RasterStack')) { x <- brick( x, values=TRUE ) # this may go to disk, hence we check again below } } if ( inMemory(x) ) { x@data@values[i] <- value x <- setMinMax(x) x <- .clearFile(x) return(x) } else if (canProcessInMemory(x)) { if (inherits(x, 'RasterStack')) { x <- brick( x, values=TRUE ) if (!inMemory(x)) { x <- readAll(x) } x <- .clearFile(x) } else if ( fromDisk(x) ) { x <- readAll(x) x <- .clearFile(x) } else { x <- setValues(x, rep(NA, times=ncell(x))) } x@data@values[i] <- value x <- setMinMax(x) return(x) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='replace') hv <- hasValues(x) if (nl==1) { if (! length(value) %in% c(1, length(i))) { stop('cannot replace values in large Raster objects if their length is not 1 or the number of cells to be replaced') } r <- raster(x) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) for (k in 1:tr$n) { # cells <- cellFromRowCol(x, tr$row[k], 1):cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x)) cell1 <- cellFromRowCol(x, tr$row[k], 1) cell2 <- cell1 + tr$nrows[k] * ncol(x) - 1 if (hv) { v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k]) } else { v <- rep(NA, 1+cell2-cell1) } j <- which(i >= cell1 & i <= cell2) if (length(j) > 0) { localcells <- i[j] - (cell1-1) if (length(value) == length(i)) { v[localcells] <- value[j] } else { v[localcells] <- value } } r <- writeValues(r, v, tr$row[k]) pbStep(pb, k) } r <- writeStop(r) pbClose(pb) return(r) } else { if (! length(value) %in% c(1, length(i))) { stop('length of replacement values does not match the length of the index') } r <- brick(x, values=FALSE) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) add <- (0:(nl-1)) * ncell(x) for (k in 1:tr$n) { cells <- cellFromRowCol(x, tr$row[k], 1):cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x)) if (hv) { v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k]) } else { v <- matrix(NA, nrow=length(cells), ncol=nl) } cells <- cells + rep(add, each=length(cells)) j <- cells %in% i if (sum(j) > 0) { v[j] <- value } r <- writeValues(r, v, tr$row[k]) pbStep(pb, k) } r <- writeStop(r) pbClose(pb) return(r) } } }
135 inifile.R
# Authors: Robert J. Hijmans # contact: r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 .strSplitOnFirstToken <- function(s, token==) { pos <- which(strsplit(s, '')[[1]]==token)[1] if (is.na(pos)) { return(c(trim(s), NA)) } else { first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } } .strSplitOnLastToken <- function(s, token==) { # not used here pos <- unlist(strsplit(s, '')) pos <- max(which(pos==token)) if (!is.finite(pos)) { return(c(s, NA)) } else { first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } } readIniFile <- function(filename, token='=', commenttoken=';', aslist=FALSE, case) { stopifnot(file.exists(filename)) Lines <- trim(readLines(filename, warn = FALSE)) ini <- lapply(Lines, function(s){ .strSplitOnFirstToken(s, token=commenttoken) } ) Lines <- matrix(unlist(ini), ncol=2, byrow=TRUE)[,1] ini <- lapply(Lines, function(s){ .strSplitOnFirstToken(s, token=token) }) ini <- matrix(unlist(ini), ncol=2, byrow=TRUE) ini <- ini[ ini[,1] != , , drop=FALSE] ns <- length(which(is.na(ini[,2]))) if (ns > 0) { sections <- c(which(is.na(ini[,2])), length(ini[,2])) # here I should check whether the section text is enclosed in [ ]. If not, it is junk text that should be removed, rather than used as a section ini <- cbind(, ini) for (i in 1:(length(sections)-1)) { ini[sections[i]:(sections[i+1]), 1] <- ini[sections[i],2] } ini[,1] <- gsub(\\[, , ini[,1]) ini[,1] <- gsub(\\], , ini[,1]) sections <- sections[1:(length(sections)-1)] ini <- ini[-sections,] } else { ini <- cbind(, ini) } if (!missing(case)) { ini <- case(ini) } colnames(ini) <- c(section, name, value) if (aslist) { iniToList <- function(ini) { un <- unique(ini[,1]) LST <- list() for (i in 1:length(un)) { sel <- ini[ini[,1] == un[i], 2:3, drop=FALSE] lst <- as.list(sel[,2]) names(lst) <- sel[,1] LST[[i]] <- lst } names(LST) <- un return(LST) } ini <- iniToList(ini) } return(ini) }
136 init.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 init <- function(x, fun, v, filename=, ...) { if (missing(fun) & missing(v)) { stop('provide either a function fun or an option v') } if (missing(fun)) { v = tolower(v[1]) stopifnot (v %in% c('x', 'y', 'row', 'col', 'cell')) } out <- raster(x) filename <- trim(filename) inmem=TRUE if (!canProcessInMemory(out, 2)) { inmem=FALSE if (filename == '') { filename <- rasterTmpFile() } } if (missing(fun)) { if ( inmem ) { if (v == 'cell') { out <- setValues(out, 1:ncell(out)) } else if (v == 'row') { out <- setValues(out, rep(1:nrow(out), each=ncol(out))) } else if (v == 'y') { out <- setValues(out, rep(yFromRow(out, 1:nrow(out)), each=ncol(out))) } else if (v == 'col') { out <- setValues(out, rep(1:ncol(out), times=nrow(out))) } else if (v == 'x') { out <- setValues(out, rep(xFromCol(out, 1:ncol(out)), times=nrow(out))) } } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='init', ...) for (i in 1:tr$n) { if (v == 'cell') { out <- writeValues(out, cellFromRowCol(out, tr$row[i],1):cellFromRowCol(out, tr$row[i]+tr$nrows[i]-1, ncol(out)), tr$row[i]) } else if (v == 'row') { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) out <- writeValues(out, rep(r, each=ncol(out)), tr$row[i]) } else if (v == 'col') { out <- writeValues(out, rep(1:ncol(out), tr$nrows[i]), tr$row[i]) } else if (v == 'x') { out <- writeValues(out, rep(xFromCol(out, 1:ncol(out)), tr$nrows[i]), tr$row[i]) } else if (v == 'y') { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) out <- writeValues(out, rep(yFromRow(out, r), each=ncol(out)), tr$row[i]) } pbStep(pb, i) } pbClose(pb) out <- writeStop(out) } } else { if ( inmem ) { n <- ncell(out) out <- setValues(out, fun(n)) } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='init', ...) for (i in 1:tr$n) { n <- ncol(out) * tr$nrows[i] out <- writeValues(out, fun(n), tr$row[i]) pbStep(pb, r) } pbClose(pb) out <- writeStop(out) } } if (inmem & filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) }
137 intDataType.R
# raster package # Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : November 2009 # Version 0.9 # Licence GPL v3 .checkIntDataType <- function(mn, mx, dtype) { mn <- round(mn) mx <- round(mx) ok <- TRUE if (dtype == 'INT') { return(.getIntDataType(mn, mx) ) } else if (dtype == 'INT1S') { if (mn < -127 | mx > 128) { ok <- FALSE } } else if (dtype == 'INT1U') { if (mn < 0 | mx > 256) { ok <- FALSE } } else if (dtype == 'INT2S') { if (mn < -32767 | mx > 32768) { ok <- FALSE } } else if (dtype == 'INT2U') { if (mn <= 0 | mx > 65534 ) { ok <- FALSE } } else if (dtype == 'INT4S') { if (mn < -2147483647 | mx > 2147483648 ) { ok <- FALSE } } else if (dtype == 'INT4U') { if (mn < 0 | mx > 2^32 ) { ok <- FALSE } # } else if (dtype == 'INT8S') { # if (mn < -2^63/2 | mx > 2^64/2) { # ok <- FALSE # } } else { stop('unknown integer type:', dtype) } if (!ok) { dtype <- .getIntDataType(mn, mx) warning('changed INT data type to: ', dtype) } return(dtype) } .getIntDataType <- function(mn, mx) { # optimize the number of bytes within the datatype if (mn > -128 & mx < 128) { datatype <- 'INT1S' } else if (mn >=0 & mx < 256) { datatype <- 'INT1U' } else if (mn > -32767 & mx < 32768) { datatype <- 'INT2S' } else if (mn >= 0 & mx < 65534 ) { datatype <- 'INT2U' } else if (mn > -2147483647 & mx < 2147483648 ) { datatype <- 'INT4S' } else if (mn > 0 & mx < 2^32 ) { datatype <- 'INT4U' ## } else if (mn > -(2^63/2) & mx < (2^64/2)) { # datatype <- 'INT8S' } else { stop('these values are too large to be saved as integers') } return(datatype) } ..intSetNA <- function(v, dtype) { if (dtype == 'INT1S') { v[v < -127 | v > 128] <- NA } else if (dtype == 'INT1U') { v[v <=0 | v > 256] <- NA } else if (dtype == 'INT2S') { v[v < -32767 | v > 32768] <- NA } else if (dtype == 'INT2U') { v[v <= 0 | v > 65534] <- NA } else if (dtype == 'INT4S') { v[v < -2147483647 | v > 2147483648] <- NA } else if (dtype == 'INT8S') { v[v < -2^63/2 | v > 2^64/2] <- NA } return(v) }
138 interpolate.R
if (!isGeneric(interpolate)) { setGeneric(interpolate, function(object, ...) standardGeneric(interpolate)) } # to do: should allow index to be a vector setMethod('interpolate', signature(object='Raster'), function(object, model, filename=, fun=predict, xyOnly=TRUE, xyNames=c('x','y'), ext=NULL, const=NULL, index=1, na.rm=TRUE, debug.level=1, ...) { predrast <- raster(object) filename <- trim(filename) ln <- NULL if (!is.null(ext)) { predrast <- crop(predrast, extent(ext)) firstrow <- rowFromY(object, yFromRow(predrast, 1)) firstcol <- colFromX(object, xFromCol(predrast, 1)) } else { firstrow <- 1 firstcol <- 1 } ncols <- ncol(predrast) lyrnames <- names(object) xylyrnames <- c('x', 'y', lyrnames) haveFactor <- FALSE dataclasses <- try( attr(model$terms, dataClasses)[-1], silent=TRUE) if (!is.null(dataclasses)) { varnames <- names(dataclasses) if (class(dataclasses) != 'try-error') { if ( length( unique(lyrnames[(lyrnames %in% varnames)] )) != length(lyrnames[(lyrnames %in% varnames)] )) { stop('duplicate names in Raster* object: ', lyrnames) } f <- names( which(dataclasses == 'factor') ) if (length(f) > 0) { haveFactor <- TRUE } } } if (!canProcessInMemory(predrast) && filename == '') { filename <- rasterTmpFile() } if (! xyOnly) { if (inherits(object, 'RasterStack')) { if (nlayers(object)==0) { warning('object has no data, xyOnly set to TRUE') xyOnly <- TRUE } } else { if ( ! fromDisk(object) ) { if (! inMemory(object) ) { warning('object has no data, xyOnly set to TRUE') xyOnly <- TRUE } } } } if (xyOnly) { na.rm <- FALSE } if (inherits(model, gstat)) { gstatmod <- TRUE if (!is.null(model$locations) && inherits(model$locations, formula)) { # should be ~x + y ; need to check if it is ~lon + lat; or worse ~y+x sp <- FALSE } else { sp <- TRUE } } else { gstatmod <- FALSE } tr <- blockSize(predrast, n=nlayers(object)+3) ablock <- 1:(ncol(predrast) * tr$nrows[1]) napred <- rep(NA, ncol(predrast)*tr$nrows[1]) pb <- pbCreate(tr$n, label='interpolate', ... ) if (filename == '') { v <- matrix(NA, ncol=nrow(predrast), nrow=ncol(predrast)) } else { predrast <- writeStart(predrast, filename=filename, ... ) } for (i in 1:tr$n) { if (i==tr$n) { ablock <- 1:(ncol(predrast) * tr$nrows[i]) napred <- rep(NA, ncol(predrast) * tr$nrows[i]) } rr <- firstrow + tr$row[i] - 1 if (xyOnly) { p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) p <- na.omit(p) blockvals <- data.frame(x=p[,1], y=p[,2]) } else { blockvals <- data.frame(getValuesBlock(object, row=rr, nrows=tr$nrows[i], firstcol, ncols)) colnames(blockvals) <- lyrnames # necessary if there is only one layer if (haveFactor) { for (i in 1:length(f)) { blockvals[,f[i]] <- as.factor(blockvals[,f[i]]) } } p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) blockvals <- cbind(data.frame( x=p[,1], y=p[,2]), blockvals) } if (! is.null(const)) { blockvals <- cbind(blockvals, const) } colnames(blockvals)[1:2] <- xyNames[1:2] if (gstatmod) { if (sp) { row.names(p) <- 1:nrow(p) blockvals <- SpatialPointsDataFrame(coords=p, data = blockvals, proj4string=projection(predrast, asText = FALSE)) } if (i == 1) { predv <- predict(model, blockvals, debug.level=debug.level, ...) ln <- names(predv)[index] } else { predv <- predict(model, blockvals, debug.level=0, ...) } if (sp) { predv <- predv@data[,index] } else { predv <- predv[,index+2] } } else { if (na.rm) { blockvals <- na.omit(blockvals) } if (nrow(blockvals) == 0 ) { predv <- napred } else { predv <- fun(model, blockvals, ...) } if (class(predv)[1] == 'list') { predv = unlist(predv) if (length(predv) != nrow(blockvals)) { predv = matrix(predv, nrow=nrow(blockvals)) } } if (isTRUE(dim(predv)[2] > 1)) { predv = predv[,index] } if (na.rm) { naind <- as.vector(attr(blockvals, na.action)) if (!is.null(naind)) { p <- napred p[-naind] <- predv predv <- p rm(p) } } # to change factor to numeric; should keep track of this to return a factor type RasterLayer predv <- as.numeric(predv) } if (filename == '') { predv = matrix(predv, nrow=ncol(predrast)) cols = tr$row[i]:(tr$row[i]+dim(predv)[2]-1) v[,cols] <- predv } else { predrast <- writeValues(predrast, predv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (gstatmod) { names(predrast) <- ln } if (filename == '') { predrast <- setValues(predrast, as.numeric(v)) # or as.vector } else { predrast <- writeStop(predrast) } return(predrast) } )
139 intersect.R
# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric(intersect)) { setGeneric(intersect, function(x, y) standardGeneric(intersect)) } setMethod('intersect', signature(x='Raster', y='ANY'), function(x, y) { y <- extent(y) crop(x, y) } ) setMethod('intersect', signature(x='Extent', y='ANY'), function(x, y) { y <- extent(y) x@xmin <- max(x@xmin, y@xmin) x@xmax <- min(x@xmax, y@xmax) x@ymin <- max(x@ymin, y@ymin) x@ymax <- min(x@ymax, y@ymax) if ((x@xmax <= x@xmin) | (x@ymax <= x@ymin) ) { #warning('Objects do not overlap') return(NULL) } return(x) } ) setMethod('intersect', signature(x='SpatialPoints', y='Raster'), function(x, y) { y <- extent(y) xy <- coordinates(x) i <- xy[,1] >= y@xmin & xy[,1] <= y@xmax & xy[,2] >= y@ymin & xy[,2] <= y@ymax x[i, ] } ) .intersectExtent <- function(x, ..., validate=TRUE) { objects <- c(x, list(...)) if (length(objects) == 1) { return(extent(x)) } e <- extent(objects[[1]]) for (i in 2:length(objects)) { e2 <- extent(objects[[i]]) e@xmin <- max(e@xmin, e2@xmin) e@xmax <- min(e@xmax, e2@xmax) e@ymin <- max(e@ymin, e2@ymin) e@ymax <- min(e@ymax, e2@ymax) } if ((e@xmax <= e@xmin) | (e@ymax <= e@ymin) ) { if (validate) { stop('Objects do not intersect') } else { return(NULL) } } return(e) }
140 intersect_sp.R
# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric(intersect)) { setGeneric(intersect, function(x, y) standardGeneric(intersect)) } setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y) { require(rgeos) x <- spChFIDs(x, as.character(1:length(x))) y <- spChFIDs(y, as.character(1:length(y))) if (! identical(proj4string(x), proj4string(y)) ) { warning('non identical CRS') y@proj4string <- x@proj4string } subs <- rgeos::gIntersects(x, y, byid=TRUE) if (sum(subs)==0) { warning('polygons do not intersect') return(NULL) } xdata <- .hasSlot(x, 'data') ydata <- .hasSlot(y, 'data') dat <- NULL if (xdata & ydata) { nms <- .goodNames(c(colnames(x@data), colnames(y@data))) colnames(x@data) <- xnames <- nms[1:ncol(x@data)] colnames(y@data) <- ynames <- nms[(ncol(x@data)+1):length(nms)] dat <- cbind(x@data[NULL, ,drop=FALSE], y@data[NULL, ,drop=FALSE]) } else if (xdata) { dat <- x@data[NULL, ,drop=FALSE] xnames <- colnames(dat) } else if (ydata) { dat <- y@data[NULL, ,drop=FALSE] ynames <- colnames(dat) } subsx <- apply(subs, 2, any) subsy <- apply(subs, 1, any) int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_not_poly=TRUE) # if (inherits(int, SpatialCollections)) { # if (is.null(int@polyobj)) { # merely touching, no intersection # #warning('polygons do not intersect') # return(NULL) # } # int <- int@polyobj # } if (!inherits(int, 'SpatialPolygons')) { # warning('polygons do not intersect') return(NULL) } if (!is.null(dat)) { ids <- do.call(rbind, strsplit(row.names(int), ' ')) rows <- 1:length(ids[,1]) if (xdata) { idsx <- match(ids[,1], rownames(x@data)) dat[rows, xnames] <- x@data[idsx, ] } if (ydata) { idsy <- match(ids[,2], rownames(y@data)) dat[rows, ynames] <- y@data[idsy, ] } rownames(dat) <- 1:nrow(dat) int <- spChFIDs(int, as.character(1:nrow(dat))) int <- SpatialPolygonsDataFrame(int, dat) } int } ) setMethod('intersect', signature(x='SpatialPoints', y='SpatialPolygons'), function(x, y) { if (!identical(proj4string(x), proj4string(y))) { warning(non identical CRS) y@proj4string <- x@proj4string } i <- over(as(x, SpatialPoints), as(y, SpatialPolygons)) i <- which(!is.na(i)) x[i, ] } )
141 isLonLat.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 .isGlobalLonLat <- function(x) { res <- FALSE tolerance <- 0.1 scale <- xres(x) if (isTRUE(all.equal(xmin(x), -180, tolerance=tolerance, scale=scale)) & isTRUE(all.equal(xmax(x), 180, tolerance=tolerance, scale=scale))) { if (couldBeLonLat(x, warnings=FALSE)) { res <- TRUE } } res } .couldBeLonLat <- function(...) { couldBeLonLat(...) } couldBeLonLat <- function(x, warnings=TRUE) { crsLL <- isLonLat(x) crsNA <- is.na(crsLL) e <- extent(x) extLL <- (e@xmin > -365 & e@xmax < 365 & e@ymin > -90.1 & e@ymax < 90.1) if (extLL & isTRUE(crsLL)) { return(TRUE) } else if (extLL & crsNA) { if (warnings) warning('CRS is NA. Assuming it is longitude/latitude') return(TRUE) } else if (isTRUE(crsLL)) { if (warnings) warning('raster has a longitude/latitude CRS, but coordinates do not match that') return(TRUE) } else { return(FALSE) } } if (!isGeneric(isLonLat)) { setGeneric(isLonLat, function(x) standardGeneric(isLonLat)) } setMethod('isLonLat', signature(x='Spatial'), function(x){ isLonLat(projection(x)) } ) setMethod('isLonLat', signature(x='BasicRaster'), # copied from the SP package (slightly adapted) #author: # ... function(x){ p4str <- projection(x) if (is.na(p4str) || nchar(p4str) == 0) { return(FALSE) } res <- grep(longlat, p4str, fixed = TRUE) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='character'), # copied from the SP package (slightly adapted) #author: # ... function(x){ res <- grep(longlat, x, fixed = TRUE) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='CRS'), # copied from the SP package (slightly adapted) #author: # ... function(x){ if (is.na(x@projargs)) { return(FALSE) } else { p4str <- trim(x@projargs) } if (is.na(p4str) || nchar(p4str) == 0) { return(FALSE) } res <- grep(longlat, p4str, fixed = TRUE) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='ANY'), function(x){ isLonLat(as.character(x)) } )
142 is.na.R
# Authors: Robert J. Hijmans, r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod(is.na, signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.na(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.na( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod(is.nan, signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.nan(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.nan( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod(is.finite, signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.finite(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.finite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod(is.infinite, signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.infinite(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.infinite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } )
143 kernelDens.R
### this is the kde2d function from the MASS packlage with minimal changes .kde2d <- function (x, y, h, n, lims) { nx <- length(x) gx <- seq.int(lims[1L], lims[2L], length.out = n[1L]) gy <- seq.int(lims[3L], lims[4L], length.out = n[2L]) h <- h/4 ax <- outer(gx, x, -)/h[1L] ay <- outer(gy, y, -)/h[2L] tcrossprod(matrix(dnorm(ax), , nx), matrix(dnorm(ay), , nx))/(nx * h[1L] * h[2L]) } .kernelDens <- function(p, x, bandwidth, ...) { .bandwidth.nrd <- function(x) { ### this function is from the MASS package r <- quantile(x, c(0.25, 0.75)) h <- (r[2L] - r[1L])/1.34 4 * 1.06 * min(sqrt(var(x)), h) * length(x)^(-1/5) } if(missing(bandwidth)) { bw <- c(.bandwidth.nrd(p[,1]), .bandwidth.nrd(p[,2])) } else { bw <- rep(bandwidth, length.out = 2L) } v <- .kde2d(p[,1], p[,2], bw, dim(x)[1:2], as.vector(t(bbox(x)))) v <- t(v) v <- v[nrow(v):1, ] setValues(x, v) } #a = kernelDens(xy, r)
144 kml_multiple.R
# Derived from functions GE_SpatialGrid and kmlOverlay # in the maptools package by Duncan Golicher, David Forrest and Roger Bivand # Adaptation for the raster package by Robert J. Hijmans # Date : October 2011 # Version 0.9 # Licence GPL v3 .zipKML <- function(kml, image, zip, overwrite=FALSE) { if (zip == ) { zip <- Sys.getenv('R_ZIPCMD', 'zip') } if (zip != ) { wd <- getwd() on.exit( setwd(wd) ) setwd(dirname(kml)) kml <- basename(kml) kmz <- extension(kml, '.kmz') if (file.exists(kmz)) { if (overwrite) { file.remove(kmz) } else { stop('kml file created, but kmz file exists, use overwrite=TRUE to overwrite it') } } image <- basename(image) if (zip=='7z') { kmzzip <- extension(kmz, '.zip') cmd <- paste(zip, 'a', kmzzip, kml, image, collapse= ) file.rename(kmzzip, kmz) } else { cmd <- paste(c(zip, kmz, kml, image), collapse= ) } sss <- try( system(cmd, intern=TRUE), silent=TRUE ) if (file.exists(kmz)) { files <- c(kml, image) files <- files[file.exists(files)] x <- file.remove(files) return(invisible(kmz)) } else { return(invisible(kml)) } } else { return(invisible(kml)) } } setMethod('KML', signature(x='RasterStackBrick'), function (x, filename, time=NULL, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) { if (! couldBeLonLat(x)) { stop(CRS of x must be longitude/latitude) } stopifnot(hasValues(x)) if (missing(filename)) { filename <- extension(basename(rasterTmpFile('G_')), '.kml') } nl <- nlayers(x) if (is.null(time)) { dotime <- FALSE atime <- time } else { dotime <- TRUE if (length(time) == nl) { when <- TRUE } else if (length(time) == nl+1) { when <- FALSE } else { stop('length(time) should equall nlayers(x) for when, or (nlayers(x)+1) for begin-end') } } x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE) kmlfile <- filename extension(kmlfile) <- '.kml' if (file.exists(kmlfile)) { if (overwrite) { file.remove(kmlfile) } else { stop('kml file exists, use overwrite=TRUE to overwrite it') } } name <- names(x) kml <- c('<?xml version=1.0 encoding=UTF-8?>', '<kml xmlns=http://www.opengis.net/kml/2.2>') kml <- c(kml, c(<Folder>, paste(<name>, extension(basename(filename), ''), </name>, sep=''))) e <- extent(x) latlonbox <- c(\t<LatLonBox>, paste(\t\t<north>, e@ymax, </north><south>, e@ymin, </south><east>, e@xmax, </east><west>, e@xmin, </west>, sep = ), \t</LatLonBox>, </GroundOverlay>) imagefile <- paste(extension(filename, ''), _, 1:nl, .png, sep=) for (i in 1:nl) { png(filename = imagefile[i], width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg=transparent) if (!is.na(colNA)) { par(mar=c(0,0,0,0), bg=colNA) } else { par(mar=c(0,0,0,0)) } if (R.Version()$minor >= 13) { image(x[[i]], col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...) } else { image(x[[i]], col=col, axes=FALSE, maxpixels=maxpixels, ...) } dev.off() a <- c(<GroundOverlay>, paste(\t<name>, name[i], </name>, sep='')) if (dotime) { if (when) { atime <- c(\t<TimeSpan>, paste(\t\t<when>, time[i], </when>, sep=''), \t</TimeSpan>) } else { atime <- c(\t<TimeSpan>, paste(\t\t<begin>, time[i], </begin>, sep=''), paste(\t\t<end>, time[i+1], </end>, sep=''), \t</TimeSpan>) } } kml <- c(kml, a, atime, paste(\t<Icon><href>, basename(imagefile[i]), </href></Icon>, sep=''), latlonbox) } kml <- c(kml, </Folder>, </kml>) cat(paste(kml, sep=, collapse=\n), file=kmlfile, sep = ) .zipKML(kmlfile, imagefile, zip, overwrite=overwrite) } )
145 kml.R
# Derived, with only minor changes, from functions GE_SpatialGrid and kml Overlay # in the maptools package. These were written by Duncan Golicher, David Forrest and Roger Bivand # Adaptation for the raster packcage by Robert J. Hijmans, # Date : March 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(KML)) { setGeneric(KML, function(x, ...) standardGeneric(KML)) } setMethod('KML', signature(x='Spatial'), function (x, filename, zip='', overwrite=FALSE, ...) { .requireRgdal() if (! is.na(projection(x))) { if (! isLonLat(x) ) { warning('transforming data to longitude/latitude') spTransform(x, CRS('+proj=longlat +datum=WGS84')) } } if (! .hasSlot(x, 'data') ) { x <- addAttrToGeom(x, data.frame(id=1:length(x)), match.ID=FALSE) } extension(filename) <- '.kml' if (file.exists(filename)) { if (overwrite) { file.remove(filename) } else { stop('file exists, use overwrite=TRUE to overwrite it') } } name <- deparse(substitute(x)) writeOGR(x, filename, name, 'KML') .zipKML(filename, '', zip, overwrite=overwrite) } ) setMethod('KML', signature(x='RasterLayer'), function (x, filename, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) { if (! couldBeLonLat(x)) { stop(CRS of x must be longitude / latitude) } if (nlayers(x) > 1) { x <- x[[1]] } stopifnot(hasValues(x)) if (missing(filename)) { filename <- extension(basename(rasterTmpFile('G_')), '.kml') } x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE) imagefile <- filename extension(imagefile) <- '.png' kmlfile <- kmzfile <- filename extension(kmlfile) <- '.kml' if (file.exists(kmlfile)) { if (overwrite) { file.remove(kmlfile) } else { stop('kml file exists, use overwrite=TRUE to overwrite it') } } png(filename = imagefile, width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg=transparent) if (!is.na(colNA)) { par(mar=c(0,0,0,0), bg=colNA) } else { par(mar=c(0,0,0,0)) } image(x, col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...) dev.off() name <- names(x)[1] if (name == ) { name <- 'x' } kml <- c('<?xml version=1.0 encoding=UTF-8?>', '<kml xmlns=http://www.opengis.net/kml/2.2>', <GroundOverlay>) kmname <- paste(<name>, name, </name>, sep = ) icon <- paste(<Icon><href>, basename(imagefile), </href><viewBoundScale>0.75</viewBoundScale></Icon>, sep = ) e <- extent(x) latlonbox <- c(\t<LatLonBox>, paste(\t\t<north>, e@ymax, </north><south>, e@ymin, </south><east>, e@xmax, </east><west>, e@xmin, </west>, sep = ), \t</LatLonBox>) footer <- </GroundOverlay></kml> kml <- c(kml, kmname, icon, latlonbox, footer) cat(paste(kml, sep=, collapse=\n), file=kmlfile, sep=) .zipKML(kmlfile, imagefile, zip, overwrite=overwrite) } )
146 layerize.R
# Author: Robert J. Hijmans # Date : August 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric(layerize)) { setGeneric(layerize, function(x, y, ...) standardGeneric(layerize)) } setMethod('layerize', signature(x='RasterLayer', y='missing'), function(x, classes=NULL, falseNA=FALSE, filename='', ...) { doC <- list(...)$doC if (is.null(doC)) doC <- TRUE if (is.null(classes)) { classes <- as.integer( sort(unique(x)) ) } else { classes <- as.integer(classes) } out <- raster(x) if (length(classes) > 1) { out <- brick(out, nl=length(classes)) } names(out) <- classes if (canProcessInMemory(out)) { v <- as.integer(getValues(x)) if (doC) { v <- .Call(layerize, v, as.integer(classes), as.integer(falseNA), PACKAGE='raster') v <- matrix(v, ncol=length(classes)) } else { v <- t( apply(matrix(v), 1, function(x) x == classes) ) if (falseNA) { v[!v] <- NA } } # alternative approach (assuming sorted classes) # alternative approach (assuming sorted classes) # vv <- cbind(1:length(v), as.integer(as.factor(v))) # if (falseNA) { # v <- matrix(NA, nrow=ncell(out), ncol=nlayers(out)) # } else { # v <- matrix(0, nrow=ncell(out), ncol=nlayers(out)) # } # v[vv] <- 1 out <- setValues(out, v*1) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } # else to disk ## out <- writeStart(out, filename=filename, datatype='INT2S', ...) # } else { out <- writeStart(out, filename=filename, ...) # } tr <- blockSize(out) pb <- pbCreate(tr$n, label='layerize', ...) fNA <- as.integer(falseNA) if (doC) { for (i in 1:tr$n) { v <- as.integer(getValues(x, tr$row[i], tr$nrows[i])) v <- .Call(layerize, v, classes, fNA, PACKAGE='raster') v <- matrix(v, ncol=length(classes)) out <- writeValues(out, v*1, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, tr$row[i], tr$nrows[i]) v <- t( apply(matrix(v, ncol=1), 1, function(x) x == classes) ) if (falseNA) { v[!v] <- NA } out <- writeValues(out, v*1, tr$row[i]) pbStep(pb, i) } } pbClose(pb) writeStop(out) } ) setMethod('layerize', signature(x='RasterLayer', y='RasterLayer'), function(x, y, classes=NULL, filename='', ...) { resx <- res(x) resy <- res(y) if (! all( resy > resx) ) { stop(x and y resolution of object y should be (much) larger than that of object x) } int <- intersect(extent(x), extent(y)) if (is.null(int)) { return(raster(y)) } if (is.null(classes)) { classes <- as.integer( sort(unique(x))) } out <- raster(y) if (length(classes) > 1) { out <- brick(out, nl=length(classes)) } names(out) <- paste('count_', as.character(classes), sep='') if (canProcessInMemory( out )) { b <- crop(x, int) xy <- xyFromCell(b, 1:ncell(b)) mc <- cellFromXY(out, xy) b <- as.integer(getValues(b)) if (!is.null(classes)) { b[! b %in% classes] <- NA } v <- table(mc, b) cells <- as.integer(rownames(v)) m <- match(cells, 1:ncell(out)) cn <- as.integer(colnames(v)) res <- matrix(NA, nrow=ncell(out), ncol=length(cn)) for (i in 1:length(cn)) { res[m,i] <- v[,i] } names(out) <- paste('count_', as.character(cn), sep='') out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } # else out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='layerize', ...) for(i in 1:tr$n) { e <- extent(xmin(y), xmax(y), yFromRow(y, tr$row[i]+tr$nrows[i]-1) - 0.5 * yres(y), yFromRow(y, tr$row[i])+0.5 * yres(y)) int <- intersect(e, extent(x)) res <- matrix(NA, nrow=tr$nrows[i] * ncol(y), ncol=length(classes)) if (!is.null(int)) { b <- crop(x, int) xy <- xyFromCell(b, 1:ncell(b)) mc <- cellFromXY(y, xy) v <- table(mc, as.integer(getValues(b))) cells <- as.integer(rownames(v)) modcells <- cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+ tr$nrows[i]-1, ncol(y)) m <- match(cells, modcells) cn <- as.integer(colnames(v)) mm <- match(cn, classes) for (j in 1:length(cn)) { res[, mm[j]] <- v[, j] } } out <- writeValues(out, res, tr$row[i]) } out <- writeStop(out) pbClose(pb) out } )
147 layerStats.R
# Jonathan Greenberg and Robert Hijmans # Date : April 2012 # Version 1.0 # Licence GPL v3 # Computation of the weighted covariance and (optionally) weighted means of bands in an Raster. # based on code by Mort Canty layerStats <- function(x, stat, w, asSample=TRUE, na.rm=FALSE, ...) { stat <- tolower(stat) stopifnot(stat %in% c('cov', 'weighted.cov', 'pearson')) stopifnot(is.logical(asSample) & !is.na(asSample)) nl <- nlayers(x) n <- ncell(x) mat <- matrix(NA, nrow=nl, ncol=nl) colnames(mat) <- rownames(mat) <- names(x) pb <- pbCreate(nl^2, label='layerStats', ...) if (stat == 'weighted.cov') { if (missing(w)) { stop('to compute weighted covariance a weights layer should be provided') } stopifnot( nlayers(w) == 1 ) if (na.rm) { # a cell is set to NA if it is NA in any layer. That is not ideal, but easier and quicker nas <- calc(x, function(i) sum(i)) * w x <- mask(x, nas) w <- mask(w, nas) } sumw <- cellStats(w, stat='sum', na.rm=na.rm) means <- cellStats(x * w, stat='sum', na.rm=na.rm) / sumw sumw <- sumw - asSample x <- (x - means) * sqrt(w) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x,layer=j) v <- cellStats(r, stat='sum', na.rm=na.rm) / sumw mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) cov.w <- list(mat, means) names(cov.w) <- c(weigthed covariance, weighted mean) return(cov.w) } else if (stat == 'cov') { means <- cellStats(x, stat='mean', na.rm=na.rm) x <- (x - means) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x, layer=j) if (na.rm) { v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - cellStats(r, stat='countNA') - asSample) } else { v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - asSample) } mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) covar <- list(mat, means) names(covar) <- c(covariance, mean) return(covar) } else if (stat == 'pearson') { means <- cellStats(x, stat='mean', na.rm=na.rm) sds <- cellStats(x, stat='sd', na.rm=na.rm) x <- (x - means) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x, layer=j) if (na.rm) { v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - cellStats(r, stat='countNA') - asSample) * sds[i] * sds[j]) } else { v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - asSample) * sds[i] * sds[j]) } mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) covar <- list(mat, means) names(covar) <- c(pearson correlation coefficient, mean) return(covar) } }
148 makeProjString.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : January 2009 # Version 0.9 # Licence GPL v3 .newCRS <- function(projs) { if (is.null(projs)) { prj <- CRS() } else if (is.na(projs)) { prj <- CRS() } else if (nchar(projs) < 3) { prj <- CRS() } else { projs <- trim(projs) prj <- try(CRS(projs), silent = TRUE) if (class(prj) == try-error) { warning(paste(projs, 'is not a valid PROJ.4 CRS string')) prj <- CRS() } } return(prj) } .makeProj <- function(projection='longlat', ..., ellipsoid=, datum=, asText=TRUE) { prj <- rgdal::projInfo(proj) ell <- rgdal::projInfo(ellps) dat <- rgdal::projInfo(datum) projection <- trim(projection) ellipsoid <- trim(ellipsoid) datum <- trim(datum) if (!(projection %in% prj[,1])) { stop(unknown projection. See rgdal::projInfo()) } else { pstr <- paste('+proj=',projection, sep=) projname <- as.vector(prj[which(prj[,1]==projection), 2]) } pargs <- list(...) if ( length(pargs) > 0 ) { for (i in 1:length(pargs)) { pstr <- paste(pstr, ' +', pargs[[i]], sep=) } } if (ellipsoid != ) { if (!(ellipsoid %in% ell[,1])) { stop(unknown ellipsoid. See rgdal::projInfo('ellps')) } else { pstr <- paste(pstr, +ellps=, ellipsoid, sep=) # ellipname <- ell[which(ell[,1]==ellipsoid), 2] } } if (datum != ) { if (!(datum %in% dat[,1])) { stop(unknown datum. See rgdal::projInfo('datum')) } else { pstr <- paste(pstr, +datum=, datum, sep=) # datumname <- as.vector(dat[which(dat[,1]==datum), 2]) } } cat(Projection: , projname[1], \n) crs <- .newCRS(pstr) if (asText) { return(trim(crs@projargs)) } else { return(crs) } }
149 makeRasterList.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : September 2008 # Version 0.9 # Licence GPL v3 .addToList <- function(x, r, compare, giveError, unstack) { if (class(r) == 'character') { r <- raster(r) # or r <- unstack(stack(r, -1)) ??? if (compare & length(x)>0) { compareRaster(x[[1]], r) } return( c(x, r) ) } else if (! extends(class(r), 'Raster')) { if (giveError) { stop('... arguments must be a filename or objects that extend the Raster class') } else { return(x) } } else if (unstack & inherits(r, 'RasterStackBrick')) { if ( compare & length(x) > 0 ) { compareRaster(x[[1]], r) } return( c(x, unstack(r)) ) } else { if (compare & length(x) > 0) { compareRaster(x[[1]], r) } return( c(x, r) ) } } .makeRasterList <- function(..., compare=FALSE, giveError=FALSE, unstack=TRUE) { arg <- list(...) x <- list() for (i in seq(along=arg)) { if (class(arg[[i]]) == 'list') { for (j in seq(along=arg[[i]])) { x <- .addToList(x, arg[[i]][[j]], compare=compare, giveError=giveError, unstack=unstack) } } else { x <- .addToList(x, arg[[i]], compare=compare, giveError=giveError, unstack=unstack) } } fdim <- sapply(x, fromDisk) & sapply(x, inMemory) if (sum(fdim) > 0) { x[fdim] <- sapply(x[fdim], clearValues) } hv <- sum(sapply(x, hasValues)) if (hv < length(x)) { if (sum(hv) == 0) { x <- x[1] } else { x <- x[hv] warning('layer(s) with no data ignored') } } return(x) }
150 mask.R
# Author: Robert J. Hijmans # Date : November 2009 # Version 1.0 # Licence GPL v3 if (!isGeneric(mask)) { setGeneric(mask, function(x, mask, ...) standardGeneric(mask)) } setMethod('mask', signature(x='Raster', mask='Spatial'), function(x, mask, filename=, inverse=FALSE, updatevalue=NA, updateNA=FALSE, ...){ mask <- rasterize(mask, x, 1, silent=TRUE) mask(x, mask, filename=filename, inverse=inverse, maskvalue=NA, updatevalue=updatevalue, ...) } ) setMethod('mask', signature(x='RasterLayer', mask='RasterLayer'), function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] compareRaster(x, mask) ln <- names(x) out <- raster(x) names(out) <- ln if ( canProcessInMemory(x, 3)) { x <- getValues(x) mask <- getValues(mask) if (is.na(maskvalue)) { if (updateNA) { if (inverse) { x[!is.na(mask)] <- updatevalue } else { x[is.na(mask)] <- updatevalue } } else { if (inverse) { x[!is.na(mask) & !is.na(x)] <- updatevalue } else { x[is.na(mask) & !is.na(x)] <- updatevalue } } } else { if (updateNA) { if (inverse) { x[mask != maskvalue] <- updatevalue } else { x[mask == maskvalue] <- updatevalue } } else { if (inverse) { x[mask != maskvalue & !is.na(x)] <- updatevalue } else { x[mask == maskvalue & !is.na(x)] <- updatevalue } } } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } else { if (filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (is.na(updatevalue)) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (updateNA) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } } pbClose(pb) out <- writeStop(out) names(out) <- ln return(out) } } ) setMethod('mask', signature(x='RasterStackBrick', mask='RasterLayer'), function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ compareRaster(x, mask) maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] out <- brick(x, values=FALSE) names(out) <- ln <- names(x) if (canProcessInMemory(x, nlayers(x)+4)) { x <- getValues(x) if (is.na(maskvalue)) { if (updateNA) { if (inverse) { x[!is.na(getValues(mask))] <- updatevalue } else { x[is.na(getValues(mask))] <- updatevalue } } else { if (inverse) { x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue } else { x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue } } } else { if (updateNA) { if (inverse) { x[getValues(mask) != maskvalue] <- updatevalue } else { x[getValues(mask) == maskvalue] <- updatevalue } } else { if (inverse) { x[getValues(mask) != maskvalue & !is.na(x)] <- updatevalue } else { x[getValues(mask) == maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (is.na(updatevalue)) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (updateNA) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } } pbClose(pb) out <- writeStop(out) names(out) <- ln return(out) } } ) setMethod('mask', signature(x='RasterLayer', mask='RasterStackBrick'), function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ compareRaster(x, mask) out <- brick(mask, values=FALSE) maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] if (canProcessInMemory(mask, nlayers(x)*2+2)) { x <- getValues(x) x <- matrix(rep(x, nlayers(out)), ncol=nlayers(out)) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { x[!is.na(getValues(mask))] <- updatevalue } else { x[is.na(getValues(mask))] <- updatevalue } } else { if (inverse) { x[getValues(mask)!=maskvalue] <- updatevalue } else { x[getValues(mask)==maskvalue] <- updatevalue } } } else { if (is.na(maskvalue)) { if (inverse) { x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue } else { x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue } } else { if (inverse) { x[getValues(mask)!=maskvalue & !is.na(x)] <- updatevalue } else { x[getValues(mask)==maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('mask', signature(x='RasterStackBrick', mask='RasterStackBrick'), function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ nlx <- nlayers(x) nlk <- nlayers(mask) if ( nlx != nlk ) { if (nlx == 1) { x <- raster(x, 1) return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...)) } if (nlk == 1) { mask <- raster(mask, 1) return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...)) } if (! ((nlx > nlk) & (nlx %% nlk == 0)) ) { stop('number of layers of x and mask must be the same,\nor one of the two should be 1, or the number of layers of x\nshould be divisible by the number of layers of mask') } } updatevalue <- updatevalue[1] maskvalue <- maskvalue[1] compareRaster(x, mask) out <- brick(x, values=FALSE) ln <- names(x) names(out) <- ln if (canProcessInMemory(x, nlx*2)) { x <- getValues(x) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { x[!is.na(as.vector(getValues(mask)))] <- updatevalue } else { x[is.na(as.vector(getValues(mask)))] <- updatevalue } } else { if (inverse) { x[as.vector(getValues(mask)) != maskvalue] <- updatevalue } else { x[as.vector(getValues(mask)) == maskvalue] <- updatevalue } } } else { if (is.na(maskvalue)) { if (inverse) { x[!is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue } else { x[is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue } } else { if (inverse) { x[as.vector(getValues(mask)) != maskvalue & !is.na(x)] <- updatevalue } else { x[as.vector(getValues(mask)) == maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) names(out) <- ln } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(!is.na(m))] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(is.na(m))] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m != maskvalue)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m == maskvalue)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(!is.na(m)) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(is.na(m)) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m != maskvalue) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m == maskvalue) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } pbClose(pb) out <- writeStop(out) names(out) <- ln return(out) } } )
151 match.R
# Author: Robert J. Hijmans # Date : October 2011 # October 2011 # version 1 # Licence GPL v3 if (!isGeneric(%in%)) { setGeneric(%in%, function(x, table) standardGeneric(%in%)) } setMethod(%in%, signature(x='Raster', table='ANY'), function(x, table) { calc(x, function(x) x %in% table) } ) if (!isGeneric(match)) { setGeneric(match, function(x, table, nomatch=NA_integer_, incomparables=NULL) standardGeneric(match)) } setMethod(match, signature(x='Raster', table='ANY', nomatch='ANY', incomparables='ANY'), function(x, table, nomatch, incomparables) { calc(x, function(x) match(x, table, nomatch, incomparables)) } )
152 math.R
# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod(Math, signature(x='Raster'), function(x){ if (!hasValues(x)) { return(x) } #funname <- as.character(sys.call(sys.parent())[[1]]) funname <- .Generic nl <- nlayers(x) if (nl > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (substr(funname, 1, 3) == 'cum' ) { if (nl == 1) { if (canProcessInMemory(r, 3)) { r <- setValues(r, do.call(funname, list(values(x)))) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) x <- readStart(x) last <- 0 for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (i==1) { v <- do.call(funname, list(v)) } else { v <- do.call(funname, list(c(last, v)))[-1] } last <- v[length(v)] r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } if (canProcessInMemory(r, 3)) { r <- setValues(r, t( apply(getValues(x), 1, funname)) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- t( apply(getValues(x, row=tr$row[i], nrows=tr$nrows[i]), 1, funname) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { r <- setValues(r, callGeneric(getValues(x))) } else { if (funname %in% c('floor', 'ceiling', 'trunc')) { datatype <- 'INT4S' } else { datatype <- .datatype() } tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } } return(r) } ) setMethod(Math, signature(x='RasterLayerSparse'), function(x){ if (!hasValues(x)) { return(x) } # funname <- as.character(sys.call(sys.parent())[[1]]) funname <- .Generic if (substr(funname, 1, 3) == 'cum' ) { setValues(x, do.call(funname, list(x@data@values))) } else { setValues(x, callGeneric(x@data@values)) } } ) setMethod(Math2, signature(x='Raster'), function (x, digits=0) { digits <- round(digits) if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, callGeneric( getValues(x), digits)) } else { if (digits <= 0) { datatype <- 'INT4S' } else { datatype <- .datatype() } tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, format=.filetype(), overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), digits ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } ) if (!isGeneric(log)) { setGeneric(log, function(x, ...) standardGeneric(log)) } setMethod(log, signature(x='Raster'), function(x, base=exp(1)){ nl <- nlayers(x) if (nl > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, log(values(x), base=base)) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, '', overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- log( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), base=base ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } )
153 maxDataType.R
.maxDatatype <- function(x) { x <- sort(x) x <- x[substr(x, 1, 3)== substr(x[1], 1, 3)] size <- max(as.integer(substr(x, 4, 4))) if (substr(x[1], 1, 3) == 'FLT') { return( paste('FLT', size, 'S', sep=) ) } else { # need to do better than this return( 'INT4S' ) } }
154 mean.R
# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 setMethod(mean, signature(x='Raster'), function(x, ..., trim=NA, na.rm=FALSE){ if (!is.na(trim)) { warning(argument 'trim' is ignored) } if (as.integer(R.Version()$minor) < 15) { old <- TRUE } else { old <- FALSE } dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- unlist(.addArgs(...)) } else { add <- NULL } out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (canProcessInMemory(x)) { x <- getValues(x) if (old) { x <- setValues(out, rowMeans(x, na.rm=na.rm)) } else { x <- setValues(out, .rowMeans(x, nc, d[3], na.rm=na.rm)) } return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='mean') out <- writeStart(out, filename=) x <- readStart(x, ...) if (old) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- rowMeans(v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMeans(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { d3 <- d[3] + length(add) if (canProcessInMemory(x)) { if (length(add) == 1) { x <- cbind(getValues(x), add) } else { x <- getValues(x) x <- t(apply(x, 1, function(i) c(i, add))) } if (old) { x <- setValues(out, rowMeans(x, na.rm=na.rm)) } else { x <- setValues(out, .rowMeans(x, nc, d3, na.rm=na.rm)) } return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='mean') out <- writeStart(out, filename=) x <- readStart(x, ...) if (old) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- t(apply(v, 1, function(i) c(i, add))) v <- rowMeans(v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- t(apply(v, 1, function(i) c(i, add))) v <- .rowMeans(v, tr$nrows[i]*d[2], d3, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } ) .sum <- function(x, add=NULL, na.rm=FALSE){ if (as.integer(R.Version()$minor) < 15) { old <- TRUE } else { old <- FALSE } out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (canProcessInMemory(x)) { if (old) { return( setValues(out, rowSums(getValues(x), na.rm=na.rm)) ) } else { return( setValues(out, .rowSums(getValues(x), nc, d[3], na.rm=na.rm)) ) } } tr <- blockSize(x) pb <- pbCreate(tr$n, label='sum') out <- writeStart(out, filename=) x <- readStart(x) if (old) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- rowSums(v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowSums(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) x <- readStop(x) return ( writeStop(out) ) } else { add <- sum(add, na.rm=na.rm) d3 <- d[3] + 1 if (canProcessInMemory(x)) { if (old) { return( setValues(out, rowSums(cbind(getValues(x), add), na.rm=na.rm)) ) } else { return( setValues(out, .rowSums(cbind(getValues(x), add), nc, d3, na.rm=na.rm)) ) } } tr <- blockSize(x) pb <- pbCreate(tr$n, label='sum') out <- writeStart(out, filename=) x <- readStart(x) if (old) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- rowSums(cbind(v, add), na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowSums(cbind(v, add), tr$nrows[i]*d[2], d3, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) x <- readStop(x) writeStop(out) } } .min <- function(x, add=NULL, na.rm=FALSE) { out <- raster(x) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowMin(getValues(x), na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='min') out <- writeStart(out, filename=) #x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMin(v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) #x <- readStop(x) return ( writeStop(out) ) } else { add <- min(add, na.rm=na.rm) if (canProcessInMemory(x)) { x <- setValues(out, .rowMin(cbind(getValues(x), add), na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='min') out <- writeStart(out, filename=) x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMin(cbind(v, add), na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return ( writeStop(out) ) } } .max <- function(x, add=NULL, na.rm=FALSE){ out <- raster(x) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowMax(getValues(x), na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='max') out <- writeStart(out, filename=) x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMax( v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { add <- max(add, na.rm=na.rm) if (canProcessInMemory(x)) { x <- setValues(out, .rowMax(cbind(getValues(x), add), na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='max') out <- writeStart(out, filename=) x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMax( cbind(v, add), na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } }
155 merge.R
# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 # redesinged for multiple row processing # and arguments ext and overlap # October 2011 # version 1 if (!isGeneric(merge)) { setGeneric(merge, function(x, y, ...) standardGeneric(merge)) } setMethod('merge', signature(x='Extent', y='ANY'), function(x, y, ...) { x <- c(x, y, list(...)) x <- sapply(x, extent) x <- x[sapply(x, function(x) inherits(x, 'Extent'))] x <- lapply(x, function(e) t(bbox(e))) x <- do.call(rbind, x) x <- apply(x, 2, range) extent(as.vector(x)) } ) setMethod('merge', signature(x='RasterStackBrick', y='missing'), function(x, ..., tolerance=0.05, filename=, ext=NULL) { nl <- nlayers(x) if (nl < 2) { return(x) } else if (nl == 2) { merge(x[[1]], x[[2]], tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext) } else { do.call(merge, c(x=x[[1]], y=x[[2]], .makeRasterList(x[[3:nl]]), tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext)) } } ) setMethod('merge', signature(x='Raster', y='Raster'), function(x, y, ..., tolerance=0.05, filename=, overlap=TRUE, ext=NULL) { x <- c(x, y, list(...)) isRast <- sapply(x, function(x) inherits(x, 'Raster')) dotargs <- x[ !isRast ] x <- x[ isRast ] compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance) if (is.null(dotargs$datatype)) { dotargs$datatype <- .commonDataType(sapply(x, dataType)) } filename <- trim(filename) dotargs$filename <- filename nl <- max(unique(sapply(x, nlayers))) bb <- .unionExtent(x) if (nl > 1) { out <- brick(x[[1]], values=FALSE, nl=nl) } else { out <- raster(x[[1]]) } out <- setExtent(out, bb, keepres=TRUE, snap=FALSE) hasV <- sapply(x, hasValues) if (!any(hasV)) { return(out) } if (!is.null(ext)) { ext <- extent(ext) out1 <- extend(out, union(ext, extent(out))) out1 <- crop(out1, ext) test <- try( intersect(extent(out), extent(out1)) ) if (class(test) == 'try-error') { stop('ext does not overlap with any of the input data') } out <- out1 ext <- extent(out) } if ( canProcessInMemory(out, 3) ) { if (!is.null(ext)) { if (overlap) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells, ] dat <- extract(x[[i]], ext) if (!is.matrix(dat)) { dat <- matrix(dat, ncol=1) } na <- ! rowSums(dat)==nl vv[na, ] <- dat[na, ] v[cells, ] <- vv } } } else { v <- rep(NA, ncell(out)) for (i in length(x):1) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) xy <- xyFromCell(out, cells) d <- extract(x[[i]], xy) j <- !is.na(d) v[cells[j]] <- d[j] } } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } else { # ignore overlap (if any) v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in length(x):1 ) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells, ] <- extract(x[[i]], ext) } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } } else { if (overlap) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells, ] dat <- getValues(x[[i]]) if (!is.matrix(dat)) { dat <- matrix(dat, ncol=1) } na <- ! rowSums(is.na(dat)) == nl vv[na, ] <- dat[na, ] v[cells, ] <- vv } } else { v <- rep(NA, ncell(out)) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells] vv[is.na(vv)] <- getValues(x[[i]])[is.na(vv)] v[cells] <- vv } } rm(vv) out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } else { # no overlap (or ignore overlap) v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in length(x):1) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells, ] <- getValues(x[[i]]) } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } } } if (is.null(ext)) { rowcol <- matrix(NA, ncol=6, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] rowcol[i,1] <- rowFromY(out, xy1[2]) # start row on new raster rowcol[i,2] <- rowFromY(out, xy2[2]) # end row rowcol[i,3] <- colFromX(out, xy1[1]) # start col rowcol[i,4] <- colFromX(out, xy2[1]) # end col rowcol[i,5] <- i # layer rowcol[i,6] <- nrow(x[[i]]) } tr <- blockSize(out) # tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1))) # tr$row <- subset(tr$row, tr$row <= nrow(out)) # tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row) # tr$n <- length(tr$row) pb <- pbCreate(tr$n, dotargs$progress, label='merge') dotargs$x <- out out <- do.call(writeStart, dotargs) if (overlap) { if (nl == 1) { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out)) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { #reverse order so that the first raster covers the second etc. vv[] <- NA r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValues(x[[ rc[j,5] ]], r1, nr), nrow=nr, byrow=TRUE) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, as.vector(t(v)), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { vv[] <- NA r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) vv[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { # not overlap for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { for (j in nrow(rc):1) { r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr) } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { # ext is not null rowcol <- matrix(NA, ncol=10, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] xyout1 <- xyFromCell(out, 1) xyout2 <- xyFromCell(out, ncell(out)) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { j <- rowFromY(out, xy1[2]) rowcol[i,1] <- ifelse(is.na(j), 1, j) # start row on new raster j <- rowFromY(out, xy2[2]) rowcol[i,2] <- ifelse(is.na(j), nrow(out), j) # end row j <- colFromX(out, xy1[1]) rowcol[i,3] <- ifelse(is.na(j), 1, j) # start col j <- colFromX(out, xy2[1]) rowcol[i,4] <- ifelse(is.na(j), ncol(out), j) # end col rowcol[i,5] <- nrow(x[[i]]) j <- rowFromY(x[[i]], xyout1[2]) rowcol[i,6] <- ifelse(is.na(j), 1, j) j <- rowFromY(x[[i]], xyout2[2]) rowcol[i,7] <- ifelse(is.na(j), nrow(x[[i]]), j) - rowcol[i,6] + 1 j <- colFromX(x[[i]], xyout1[1]) rowcol[i,8] <- ifelse(is.na(j), 1, j) j <- colFromX(x[[i]], xyout2[1]) rowcol[i,9] <- ifelse(is.na(j), ncol(x[[i]]), j) - rowcol[i,8] + 1 rowcol[i,10] <- i # layer } } rowcol <- subset(rowcol, !is.na(rowcol[,1])) tr <- blockSize(out) # tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1))) # tr$row <- subset(tr$row, tr$row <= nrow(out)) # tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row) # tr$n <- length(tr$row) pb <- pbCreate(tr$n, dotargs$progress, label='merge') dotargs$x <- out out <- do.call(writeStart, dotargs) if (overlap) { if (nl == 1) { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out)) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { #reverse order so that the first raster covers the second etc. vv[] <- NA r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]), nrow=nr, byrow=TRUE) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, as.vector(t(v)), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { vv[] <- NA r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) vv[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { # no overlap for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { for (j in nrow(rc):1) { r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } pbClose(pb) writeStop(out) } )
156 metadata.R
metadata <- function(x) { x@history } 'metadata<-' <- function(x, value) { stopifnot(is.list(value)) if (is.data.frame(values)) { values <- as.list(values) } if ( any(unlist(sapply(value, function(x)sapply(x, is.list)))) ) { stop('invalid metadata: list is nested too deeply') } nms <- c(names(value), unlist(sapply(value, names))) if (is.null(names) | any(nms == '')) { stop('invalid metadata: list elements without names') } if (any(unlist(sapply(value, is.data.frame)) )) { stop('invalid metadata: data.frames are not allowed') } type <- rapply(value, class) if (any(type == 'matrix')) { stop('invalid metadata: matrices are not allowed') } x@history <- value x }
157 minValue.R
# raster package # Authors: Robert J. Hijmans # Date : September 2009 # Version 1.0 # Licence GPL v3 if (!isGeneric(minValue)) { setGeneric(minValue, function(x, ...) standardGeneric(minValue)) } setMethod('minValue', signature(x='RasterLayer'), function(x, layer=-1, warn=TRUE) { if ( x@data@haveminmax ) { v <- x@data@min if (isTRUE( v == Inf)) { v <- NA } else { if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } } return(v) } else { if (warn) warning('min value not known, use setMinMax') return(NA) } } ) setMethod('minValue', signature(x='RasterBrick'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] if (layer < 1) { if ( x@data@haveminmax ) { v <- x@data@min v[v == Inf] <- NA if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } return(v) } else { warning('min value not known, use setMinMax') return(rep(NA, nlayers(x))) } } else { if ( x@data@haveminmax ) { v <- x@data@min[layer] * x@data@gain + x@data@offset v[v == Inf] <- NA return(v) } else { warning('min value not known, use setMinMax') return(NA) } } } ) setMethod('minValue', signature(x='RasterStack'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] nl <- nlayers(x) if (layer < 1) { v <- vector(length=nl) for (i in 1:nl) { v[i] <- minValue(x@layers[[i]], warn=warn) } } else { if (layer <= nl) { v <- minValue(x@layers[[layer]]) } else { stop('incorrect layer number') } } return(v) } ) if (!isGeneric(maxValue)) { setGeneric(maxValue, function(x, ...) standardGeneric(maxValue)) } setMethod('maxValue', signature(x='RasterLayer'), function(x, layer=-1, warn=TRUE) { if ( x@data@haveminmax ) { v <- x@data@max if (isTRUE( v == -Inf)) { v <- NA } else { if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } } return(v) } else { if (warn) warning('max value not known, use setMinMax') return(NA) } } ) setMethod('maxValue', signature(x='RasterBrick'), function(x, layer=-1, warn=FALSE) { if ( x@data@haveminmax ) { v <- x@data@max v[!is.finite(v)] <- NA if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } return(v) } else { if (warn) warning('max value not known, use setMinMax') v <- rep(NA, nlayers(x)) } layer <- round(layer)[1] if (layer > 0) { if (layer <= nlayers(x)) { v <- v[layer] } else { stop('invalid layer selected') } } return(v) } ) setMethod('maxValue', signature(x='RasterStack'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] nl <- nlayers(x) if (layer < 1) { v <- vector(length=nl) for (i in 1:nl) { v[i] <- maxValue(x@layers[[i]], warn=warn) } } else { if (layer <= nl) { v <- maxValue(x@layers[[layer]]) } else { stop('incorrect layer number') } } return(v) } )
158 modal.R
# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 0.9 # Licence GPL v3 setGeneric(modal, function(x, ...) standardGeneric(modal)) setMethod('modal', signature(x='ANY'), function(x, ..., ties='random', na.rm=FALSE, freq=FALSE) { #partly based on http://wiki.r-project.org/rwiki/doku.php?id=tips:stats-basic:modalvalue x <- c(x, ...) z <- x[!is.na(x)] if (freq) { if (length(z) == 0) { return(NA) } else if (!na.rm & length(z) < length(x)) { return(NA) } else if (length(z) == 1) { return(1) } else { return(max( table(z) )) } } # else .... if (!ties %in% c('lowest', 'highest', 'NA', 'random')) { stop(the value of 'ties' should be 'lowest', 'highest', 'NA', or 'random') } if (length(z) == 0) { return(NA) } else if (!na.rm & length(z) < length(x)) { return(NA) } else if (length(z) == 1) { return(z) } else { freq <- table(z) if (is.numeric(z)){ w <- as.numeric(names(freq[max(freq)==freq])) } else if (is.logical(z)) { w <- as.logical(freq[max(freq)==freq]) } else { w <- names(freq[max(freq)==freq]) } if (length(w) > 1) { if (ties == 'lowest') { w <- min(w) if (is.logical(z)) { w <- as.logical(w) } } else if (ties == 'highest') { w <- max(w) if (is.logical(z)) { w <- as.logical(w) } } else if (ties == 'NA') { w <- NA } else { # random r <- runif(length(w)) w <- w[which.max(r)] } } return(w) } } )
159 modalRaster.R
# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 setMethod(modal, signature(x='Raster'), function(x, ..., ties='random', na.rm=FALSE, freq=FALSE){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- .addArgs(...) } else { add <- NULL } nl <- nlayers(x) if (nl < 2) { stop('there is not much point in computing a modal value for a single layer') } else if (nl == 2) { warning('running modal with only two layers!') } out <- raster(x) if (canProcessInMemory(x)) { x <- cbind(getValues(x), add) x <- setValues(out, apply(x, 1, modal, ties=ties, na.rm=na.rm, freq=freq)) return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n, label='modal') out <- writeStart(out, filename=) for (i in 1:tr$n) { v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add) v <- apply(v, 1, modal, ties=ties, na.rm=na.rm, freq=freq) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) writeStop(out) } )
160 moran.R
# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 ..moran <- function(x, directions=8) { stopifnot(directions %in% c(4,8)) # not memory safe adj <- adjacent(x, 1:ncell(x), target=1:ncell(x), directions=8, pairs=TRUE) z <- x - cellStats(x, mean) wZiZj <- na.omit(z[adj[,1]] * z[adj[,2]]) z2 <- cellStats(z*z, sum) NS0 <- (ncell(z)-cellStats(z, 'countNA')) / length(wZiZj) mI <- NS0 * sum(wZiZj) / z2 return(mI) } Moran <- function(x, w=matrix(1,3,3) ) { z <- x - cellStats(x, mean) wZiZj <- focal(z, w=w, fun='sum', na.rm=TRUE, pad=TRUE) wZiZj <- overlay(wZiZj, z, fun=function(x,y){ x * y }) wZiZj <- cellStats(wZiZj, sum) z2 <- cellStats(z*z, sum) n <- ncell(z) - cellStats(z, 'countNA') # weights if (sum(! unique(w) %in% 0:1) > 0) { zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal( zz, w=w, fun='sum', na.rm=TRUE, pad=TRUE) } else { w2 <- w w2[w2==0] <- NA W <- focal( z, w=w2, fun=function(x, ...){ as.double(sum(!is.na(x))) }, pad=TRUE) } NS0 <- n / cellStats(W, sum) mI <- NS0 * wZiZj / z2 return(mI) } MoranLocal <- function(x, w=matrix(1,3,3)) { z <- x - cellStats(x, mean) #weights #w <- .getFilter(w) if (sum(! unique(w) %in% 0:1) > 0) { zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal( zz, w=w, na.rm=TRUE, pad=TRUE) } else { w2 <- w w2[w2==0] <- NA W <- focal( z, w=w2, fun=function(x, ...){ sum(!is.na(x)) }, na.rm=TRUE, pad=TRUE) } lz <- focal(z, w=w, na.rm=TRUE, pad=TRUE) / W n <- ncell(x) - cellStats(x, 'countNA') s2 <- cellStats(x, sd)^2 # adjust variance denominator from n-1 to n s2 <- (s2 * (n-1)) / n (z / s2) * lz }
161 mosaic.R
# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 # redesigned for multiple row processing # October 2011 # version 1 if (!isGeneric(mosaic)) { setGeneric(mosaic, function(x, y, ...) standardGeneric(mosaic)) } setMethod('mosaic', signature(x='Raster', y='Raster'), function(x, y, ..., fun, tolerance=0.05, filename=) { x <- c(x, y, list(...)) isRast <- sapply(x, function(x) inherits(x, 'Raster')) dotargs <- x[ !isRast ] x <- x[ isRast ] if (is.null(dotargs$datatype)) { dotargs$datatype <- .commonDataType(sapply(x, dataType)) } filename <- trim(filename) dotargs$filename <- filename nl <- max(unique(sapply(x, nlayers))) compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance) bb <- .unionExtent(x) if (nl > 1) { out <- brick(x[[1]], values=FALSE, nl=nl) } else { out <- raster(x[[1]]) } out <- setExtent(out, bb, keepres=TRUE, snap=FALSE) fun <- .makeTextFun(fun) if (class(fun) == 'character') { rowcalc <- TRUE fun <- .getRowFun(fun) } else { rowcalc <- FALSE } if ( canProcessInMemory(out, 2 + length(x)) ) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out)*nl, ncol=length(x)) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) cells <- cells + rep(0:(nl-1)*ncell(out), each=length(cells)) v[cells, i] <- as.vector(getValues(x[[i]])) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } v <- matrix(v, ncol=nl) } else { v <- matrix(NA, nrow=ncell(out), ncol=length(x)) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells,i] <- getValues(x[[i]]) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } rowcol <- matrix(NA, ncol=6, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] rowcol[i,1] <- rowFromY(out, xy1[2]) # start row on new raster rowcol[i,2] <- rowFromY(out, xy2[2]) # end row rowcol[i,3] <- colFromX(out, xy1[1]) # start col rowcol[i,4] <- colFromX(out, xy2[1]) # end col rowcol[i,5] <- i # layer rowcol[i,6] <- nrow(x[[i]]) } tr <- blockSize(out) pb <- pbCreate(tr$n, dotargs$progress, label='mosaic') dotargs$x <- out out <- do.call(writeStart, dotargs) if (nl == 1) { for (i in 1:tr$n) { rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { v <- matrix(NA, nrow=tr$nrow[i] * ncol(out), ncol=nrow(rc)) for (j in 1:nrow(rc)) { r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, j] <- getValues(x[[ rc[j,5] ]], r1, nr) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } } else { v <- rep(NA, tr$nrow[i] * ncol(out)) } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out) * nl, ncol=nrow(rc)) for (j in 1:nrow(rc)) { r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) cells <- cells + rep(0:(nl-1)* tr$nrow[i]*ncol(out), each=length(cells)) v[cells, j] <- as.vector( getValues(x[[ rc[j,5] ]], r1, nr) ) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } v <- matrix(v, ncol=nl) } else { v <- matrix(NA, nrow=tr$nrow[i] * ncol(out), ncol=nl) } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) writeStop(out) } )
162 movingFun.R
# Author: Robert Hijmans # November 2009 # License GPL3 # First versions were based on the rollFun function implemented by Diethelm Wuertz in the # fTrading package # Version: 2100.76 # Published: 2009-09-29 movingFun <- function(x, n, fun=mean, type='around', circular=FALSE, na.rm=FALSE) { n <- round(abs(n)) if (n == 0) { stop('n == 0') } x = as.vector(x) lng <- length(x) if (type == 'around') { hn <- floor(n/2) if (circular) { x <- c(x[(lng-hn+1):lng], x, x[1:hn]) } else { x <- c(rep(NA, hn), x, rep(NA, hn)) } } else if (type == 'to') { if (circular) { x <- c(x[(lng-n+2):lng], x) } else { x <- c(rep(NA, n-1), x) } } else if (type == 'from') { if (circular) { x <- c(x, x[1:n]) } else { x <- c(x, rep(NA, n)) } } else { stop('unknown type; should be around, to, or from') } m <- matrix(ncol=n, nrow=lng) for (i in 1:n) { m[,i] <- x[i:(lng+i-1)] } apply(m, MARGIN=1, FUN=fun, na.rm=na.rm) }
163 multiCore.R
# Author: Matteo Mattiuzzi and Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 beginCluster <- function(n, type='SOCK', nice, exclude=NULL) { if (! require(snow) ) { stop('you need to install the snow package') } if (exists('raster_Cluster_raster_Cluster', envir=.GlobalEnv)) { endCluster() } if (missing(n)) { n <- .detectCores() cat(n, 'cores detected\n') } # if (missing(type)) { # type <- getClusterOption(type) # cat('cluster type:', type, '\n') # } cl <- snow::makeCluster(n, type) cl <- .addPackages(cl, exclude=exclude) options(rasterClusterObject = cl) options(rasterClusterCores = length(cl)) options(rasterCluster = TRUE) options(rasterClusterExclude = exclude) if (!missing(nice)){ if (.Platform$OS.type == 'unix') { cmd <- paste(renice,nice,-p) foo <- function() system(paste(cmd, Sys.getpid())) snow::clusterCall(cl,foo) } else { warning(argument 'nice' only supported on UNIX like operating systems) } } } endCluster <- function() { options(rasterCluster = FALSE) cl <- options('rasterClusterObject')[[1]] if (! is.null(cl)) { snow::stopCluster( cl ) options(rasterClusterObject = NULL) } } .doCluster <- function() { if ( isTRUE( getOption('rasterCluster')) ) { return(TRUE) } return(FALSE) } getCluster <- function() { cl <- getOption('rasterClusterObject') if (is.null(cl)) { stop('no cluster available, first use beginCluster') } cl <- .addPackages(cl, exclude=c('raster', 'sp', getOption('rasterClusterExclude'))) options( rasterClusterObject = cl ) options( rasterCluster = FALSE ) return(cl) } returnCluster <- function() { cl <- getOption('rasterClusterObject') if (is.null(cl)) { stop('no cluster available') } options( rasterCluster = TRUE ) } .addPackages <- function(cl, exclude=NULL) { pkgs <- .packages() i <- which( pkgs %in% c(exclude, stats, graphics, grDevices, utils, datasets, methods, base) ) pkgs <- rev( pkgs[-i] ) for ( pk in pkgs ) { snow::clusterCall(cl, library, pk, character.only=TRUE ) } return(cl) }
164 names.R
# Author: Robert J. Hijmans # Date: October 2008 # Version 0.9 # Licence GPL v3 .uniqueNames <- function(x, sep='.') { y <- as.matrix(table(x)) y <- y[y[,1] > 1, ,drop=F] if (nrow(y) > 0) { y <- rownames(y) for (i in 1:length(y)) { j <- which(x==y[i]) x[j] <- paste(x[j], sep, 1:length(j), sep='') } } x } .goodNames <- function(ln, prefix='layer') { validNames(ln, prefix) } validNames <- function(x, prefix='layer') { x <- trim(as.character(x)) x[is.na(x)] <- if (.standardnames()) { x[x==''] <- prefix x <- make.names(x, unique=FALSE) } .uniqueNames(x) } setMethod('labels', signature(object='Raster'), function(object) { names(object) } ) setMethod('names', signature(x='Raster'), function(x) { if (.hasSlot(x@data, 'names')) { ln <- x@data@names } else { ln <- x@layernames } ln <- ln[1:nlayers(x)] validNames(as.vector(ln)) } ) setMethod('names', signature(x='RasterStack'), function(x) { ln <- sapply(x@layers, function(i) i@data@names) ln <- ln[1:nlayers(x)] validNames(as.vector(ln)) } ) setMethod('names<-', signature(x='Raster'), function(x, value) { nl <- nlayers(x) if (is.null(value)) { value <- rep('', nl) } else if (length(value) != nl) { stop('incorrect number of layer names') } value <- validNames(value) if (inherits(x, 'RasterStack')){ x@layers <- sapply(1:nl, function(i){ r <- x@layers[[i]] r@data@names <- value[i] r }) } else { if (.hasSlot(x@data, 'names')) { x@data@names <- value } else { x@layernames <- value } } return(x) } )
165 naValue.R
# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .naChanged <- function(x) { if (.hasSlot(x@file, 'NAchanged')) { return(x@file@NAchanged) } else { return(TRUE) } } 'NAvalue<-' <- function(x, value) { if (inherits(x, 'RasterStack')) { nl <- nlayers(x) if (length(value) == 1) { value <- rep(value[[1]], nl) } else { v <- vector(length=nl) v[] <- as.vector(value) value <- v } for (i in 1:nl) { x@layers[[i]]@file@nodatavalue <- value[i] x@layers[[i]]@file@NAchanged <- TRUE } } else { x@file@nodatavalue <- value[[1]] x@file@NAchanged <- TRUE } return(x) } NAvalue <- function(x) { if (inherits(x, 'RasterStack')) { sapply(x@layers, function(x) { x@file@nodatavalue }) } else { return(x@file@nodatavalue) } }
166 ncell.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : April 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric(ncell)) { setGeneric(ncell, function(x) standardGeneric(ncell)) } setMethod('ncell', signature(x='BasicRaster'), function(x) { return(as.numeric(x@ncols) * x@nrows) } ) setMethod('ncell', signature(x='ANY'), function(x) { NROW(x) * NCOL(x) } ) setMethod('length', signature(x='BasicRaster'), function(x) { ncell(x) * nlayers(x) } )
167 netCDFreadCells.R
# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .readRasterCellsNetCDF <- function(x, cells) { # read all if (canProcessInMemory(x, 2)) { r <- getValues(x) r <- r[cells] return(r) } if (canProcessInMemory(x, 2)) { # read only rows needed row1 <- rowFromCell(x, min(cells)) row2 <- rowFromCell(x, max(cells)) ncl <- (row2 - row1 + 1) * x@ncols r <- raster(nrow=1, ncol=ncl) v <- getValues(x, row1, row2-row1+1) v <- v[cells-cellFromRowCol(x, row1, 1)+1] return(v) } # read row by row colrow <- matrix(ncol=3, nrow=length(cells)) colrow[,1] <- colFromCell(x, cells) colrow[,2] <- rowFromCell(x, cells) colrow[,3] <- NA rows <- sort(unique(colrow[,2])) readrows <- rows if ( x@file@toptobottom ) { readrows <- x@nrows - readrows + 1 } zvar = x@data@zvar time = x@data@band if (isTRUE(getOption('rasterNCDF4'))) { nc <- ncdf4::nc_open(x@file@name) on.exit( ncdf4::nc_close(nc) ) getfun <- ncdf4::ncvar_get } else { nc <- ncdf::open.ncdf(x@file@name) on.exit( ncdf::close.ncdf(nc) ) getfun <- ncdf::get.var.ncdf } if (nc$var[[zvar]]$ndims == 1) { ncx <- x@ncols count <- ncx for (i in 1:length(rows)) { start <- (readrows[i]-1) * ncx + 1 v <- as.vector(getfun(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else if (nc$var[[zvar]]$ndims == 2) { count <- c(x@ncols, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i]) v <- as.vector(getfun(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else if (nc$var[[zvar]]$ndims == 3) { count <- c(x@ncols, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], time) v <- as.vector(getfun(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else { if (x@data@dim3 == 4) { count <- c(x@ncols, 1, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], x@data@level, time) v <- as.vector(getfun(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else { count <- c(x@ncols, 1, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], time, x@data@level) v <- as.vector(getfun(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } } colrow <- colrow[,3] #if (!is.na(x@file@nodatavalue)) { colrow[colrow==x@file@nodatavalue] <- NA } #colrow <- x@data@add_offset + colrow * x@data@scale_factor colrow[colrow == x@file@nodatavalue] <- NA return(colrow) } .readBrickCellsNetCDF <- function(x, cells, layer, nl) { i <- which(!is.na(cells)) if (length(cells) > 1000) { if (canProcessInMemory(x, 2)) { # read all endlayer <- layer+nl-1 r <- getValues(x) r <- r[cells, layer:endlayer] return(r) } } # read cell by cell zvar <- x@data@zvar dim3 <- x@data@dim3 cols <- colFromCell(x, cells) rows <- rowFromCell(x, cells) if ( x@file@toptobottom ) { rows <- x@nrows - rows + 1 } if (getOption('rasterNCDF4')) { nc <- ncdf4::nc_open(x@file@name) on.exit( ncdf4::nc_close(nc) ) getfun <- ncdf4::ncvar_get } else { nc <- ncdf::open.ncdf(x@file@name) on.exit( ncdf::close.ncdf(nc) ) getfun <- ncdf::get.var.ncdf } # this needs to be optimized. Read chunks and extract cells j <- which(!is.na(cells)) if (nc$var[[zvar]]$ndims == 2) { count <- c(1, 1) res <- matrix(NA, nrow=length(cells), ncol=1) for (i in j) { start <- c(cols[i], rows[i]) res[i] <- getfun(nc, varid=zvar, start=start, count=count) } } else if (nc$var[[zvar]]$ndims == 3) { count <- c(1, 1, nl) res <- matrix(NA, nrow=length(cells), ncol=nl) for (i in j) { start <- c(cols[i], rows[i], layer) res[i,] <- getfun(nc, varid=zvar, start=start, count=count) } } else { if (x@data@dim3 == 4) { count <- c(1, 1, 1, nl) res <- matrix(NA, nrow=length(cells), ncol=nl) for (i in j) { start <- c(cols[i], rows[i], x@data@level, layer) res[i,] <- getfun(nc, varid=zvar, start=start, count=count) } } else { count <- c(1, 1, nl, 1) res <- matrix(nrow=length(cells), ncol=nl) for (i in 1:length(cells)) { start <- c(cols[i], rows[i], layer, 1) res[i,] <- getfun(nc, varid=zvar, start=start, count=count) } } } #if (!is.na(x@file@nodatavalue)) { res[res==x@file@nodatavalue] <- NA } #res <- x@data@add_offset + res * x@data@scale_factor res[res == x@file@nodatavalue] <- NA return(res) }
168 netCDFread.R
# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .readRowsNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1)) { if ( x@file@toptobottom ) { row <- x@nrows - row - nrows + 2 } is.open <- x@file@open if (isTRUE(getOption('rasterNCDF4'))) { if (is.open) { nc <- x@file@con } else { nc <- ncdf4::nc_open(x@file@name) on.exit( ncdf4::nc_close(nc) ) } ncdf4 <- TRUE } else { if (is.open) { nc <- x@file@con } else { nc <- ncdf::open.ncdf(x@file@name) on.exit( ncdf::close.ncdf(nc) ) } ncdf4 <- FALSE } zvar <- x@data@zvar if (nc$var[[zvar]]$ndims == 1) { # for GMT ncx <- ncol(x) start <- (row-1) * ncx + 1 count <- nrows * ncx if (ncdf4) { d <- ncdf4::ncvar_get( nc, varid=zvar, start=start, count=count ) } else { d <- ncdf::get.var.ncdf( nc, varid=zvar, start=start, count=count ) } if (col > 1 | ncols < ncx) { d <- matrix(d, ncol=ncx, byrow=TRUE) d <- d[, col:(col+ncols-1)] d <- as.vector(t(d)) } } else if (nc$var[[zvar]]$ndims == 2) { start <- c(col, row) count <- c(ncols, nrows) if (ncdf4) { d <- ncdf4::ncvar_get( nc, varid=zvar, start=start, count=count ) } else { d <- ncdf::get.var.ncdf( nc, varid=zvar, start=start, count=count ) } } else if (nc$var[[zvar]]$ndims == 3) { start <- c(col, row, x@data@band) count <- c(ncols, nrows, 1) if (ncdf4) { d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count) } } else { if (x@data@dim3 == 4) { start <- c(col, row, x@data@level, x@data@band) count <- c(ncols, nrows, 1, 1) if (ncdf4) { d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count) } } else { start <- c(col, row, x@data@band, x@data@level) count <- c(ncols, nrows, 1, 1) if (ncdf4) { d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count) } } } #if (!is.na(x@file@nodatavalue)) { d[d==x@file@nodatavalue] <- NA } #d <- x@data@add_offset + d * x@data@scale_factor if (length(dim(d)) > 1) { if ( x@file@toptobottom ) { d <- d[, ncol(d):1] } } d <- as.vector(d) d[d == x@file@nodatavalue] <- NA return(d) } .readRowsBrickNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) { is.open <- x@file@open if ( x@file@toptobottom ) { row <- x@nrows - row - nrows + 2 } navalue <- x@file@nodatavalue #n the true number of layers #nn the span of layers between the first and the last #alyrs, the layers requested, scaled to start at one. n <- nn <- nlayers(x) if (missing(lyrs)) { layer <- 1 lyrs <- 1:n } else { lyrs <- lyrs[lyrs %in% 1:n] if (length(lyrs) == 0) { stop(no valid layers) } layer <- lyrs[1] n <- length(lyrs) nn <- lyrs[length(lyrs)] - lyrs[1] + 1 } alyrs <- lyrs - lyrs[1] + 1 lns <- names(x)[lyrs] nrows <- min(round(nrows), x@nrows-row+1) ncols <- min((x@ncols-col+1), ncols) stopifnot(nrows > 0) stopifnot(ncols > 0) if (getOption('rasterNCDF4')) { if (is.open) { nc <- x@file@con } else { nc <- ncdf4::nc_open(x@file@name) on.exit( ncdf4::nc_close(nc) ) } ncdf4 <- TRUE } else { if (is.open) { nc <- x@file@con } else { nc <- ncdf::open.ncdf(x@file@name) on.exit( ncdf::close.ncdf(nc) ) } ncdf4 <- FALSE } zvar <- x@data@zvar if (nc$var[[zvar]]$ndims == 4) { if (x@data@dim3 == 4) { start <- c(col, row, x@data@level, layer) count <- c(ncols, nrows, 1, nn) } else { start <- c(col, row, layer, x@data@level) count <- c(ncols, nrows, nn, 1) } } else { start <- c(col, row, layer) count <- c(ncols, nrows, nn) } if (ncdf4) { d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count) } #if (!is.na(x@file@nodatavalue)) { d[d==x@file@nodatavalue] <- NA } #d <- x@data@add_offset + d * x@data@scale_factor if (nlayers(x) > 1) { dims = dim(d) if (length(dims) == 3) { if ( x@file@toptobottom ) { v <- matrix(nrow=nrows*ncols, ncol=n) for (i in 1:length(alyrs)) { x <- d[,,alyrs[i]] v[,i] <- as.vector( x[, ncol(x):1] ) } } else { dim(d) = c(dims[1] * dims[2], dims[3]) d <- d[, alyrs, drop=FALSE] d[d == x@file@nodatavalue] <- NA return(d) } } else if (length(dims) == 2) { if (nrows==1) { d <- d[ , alyrs,drop=FALSE] d[d == navalue] <- NA return(d) } else if (n==1) { v <- matrix(nrow=nrows*ncols, ncol=n) if ( x@file@toptobottom ) { v[] <- as.vector(d[,ncol(d):1]) } else { v[] <- as.vector(d) } } else if (ncols==1) { if ( x@file@toptobottom ) { d <- d[nrow(d):1, ] } d <- d[ , alyrs, drop=FALSE] d[d == navalue] <- NA return(d) } } else { # length(dims) == 1 v <- matrix(nrow=nrows*ncols, ncol=n) if ( x@file@toptobottom & nrows > 1) { d <- rev(d) } v[] <- d # d[, alyrs, drop=FALSE] } } else { if ( x@file@toptobottom ) { if (is.matrix(d)) { d <- d[, ncol(d):1] } } v <- matrix(as.vector(d), ncol=1) #v <- v[,lyrs,drop=FALSE] } v[v == navalue] <- NA colnames(v) <- lns return(v) }
169 netCDFtoRasterCD.R
# Author: Robert J. Hijmans # Date: Aug 2009 # Version 1.0 # Licence GPL v3 # Aug 2012, adapted for use with ncdf4 library .doTime <- function(x, nc, zvar, dim3, ncdf4) { dodays <- TRUE dohours <- FALSE un <- nc$var[[zvar]]$dim[[dim3]]$units if (substr(un, 1, 10) == days since) { startDate = as.Date(substr(un, 12, 22)) } else { if (substr(un, 1, 11) == hours since) { dohours <- TRUE } dodays <- FALSE } if (dohours) { startTime <- substr(un, 13, 30) startTime <- strptime(startTime, %Y-%m-%d %H:%M:%OS) time <- startTime + as.numeric(getZ(x)) * 3600 time <- as.character(time) if (!is.na(time[1])) { x@z <- list(time) names(x@z) <- as.character('Date/time') } } else if (dodays) { # cal = nc$var[[zvar]]$dim[[dim3]]$calendar ? if (ncdf4) { cal <- ncdf4::ncatt_get(nc, time, calendar) } else { cal <- ncdf::att.get.ncdf(nc, time, calendar) } if (! cal$hasatt ) { greg <- TRUE } else { cal <- cal$value if (cal =='gregorian' | cal =='proleptic_gregorian' | cal=='standard') { greg <- TRUE } else if (cal == 'noleap' | cal == '365 day' | cal == '365_day') { greg <- FALSE nday <- 365 } else if (cal == '360_day') { greg <- FALSE nday <- 360 } else { greg <- TRUE warning('assuming a standard calender:', cal) } } time <- getZ(x) if (greg) { time <- as.Date(time, origin=startDate) } else { startyear <- as.numeric( format(startDate, %Y) ) startmonth <- as.numeric( format(startDate, %m) ) startday <- as.numeric( format(startDate, %d) ) year <- trunc( as.numeric(time)/nday ) doy <- (time - (year * nday)) origin <- paste(year+startyear, -, startmonth, -, startday, sep='') time <- as.Date(doy, origin=origin) } x@z <- list(time) names(x@z) <- 'Date' } return(x) } .dimNames <- function(nc) { n <- nc$dim nams <- vector(length=n) if (n > 0) { for (i in 1:n) { nams[i] <- nc$dim[[i]]$name } } return(nams) } .varName <- function(nc, varname='', warn=TRUE) { n <- nc$nvars dims <- vars <- vector(length=n) if (n > 0) { for (i in 1:n) { vars[i] <- nc$var[[i]]$name dims[i] <- nc$var[[i]]$ndims } vars <- vars[dims > 1] dims <- dims[dims > 1] } if (varname=='') { nv <- length(vars) if (nv == 0) { return('z') } if (nv == 1) { varname <- vars } else { varname <- vars[which.max(dims)] if (warn) { if (sum(dims == max(dims)) > 1) { vars <- vars[dims==max(dims)] warning('varname used is: ', varname, '\nIf that is not correct, you can set it to one of: ', paste(vars, collapse=, ) ) } } } } zvar <- which(varname == vars) if (length(zvar) == 0) { stop('varname: ', varname, ' does not exist in the file. Select one from:\n', paste(vars, collapse=, ) ) } return(varname) } .rasterObjectFromCDF <- function(filename, varname='', band=NA, type='RasterLayer', lvar=3, level=0, warn=TRUE, dims=1:3, crs=NA, stopIfNotEqualSpaced=TRUE, ...) { ncdf4 <- .NCDFversion4() if (ncdf4) { options(rasterNCDF4 = TRUE) nc <- ncdf4::nc_open(filename) on.exit( ncdf4::nc_close(nc) ) conv <- ncdf4::ncatt_get(nc, 0, Conventions) } else { options(rasterNCDF4 = FALSE) nc <- ncdf::open.ncdf(filename) on.exit( ncdf::close.ncdf(nc) ) conv <- ncdf::att.get.ncdf(nc, 0, Conventions) } # assuming CF-1.0 zvar <- .varName(nc, varname, warn=warn) # datatype <- .getRasterDTypeFromCDF( nc$var[[zvar]]$prec ) dim3 <- dims[3] ndims <- nc$var[[zvar]]$ndims if (ndims== 1) { return(.rasterObjectFromCDF_GMT(nc, ncdf4)) } else if (ndims == 4) { if (type != 'RasterQuadBrick') { nlevs <- nc$var[[zvar]]$dim[[lvar]]$len if (level <=0 ) { level <- 1 if (nlevs > 1) { warning('level set to 1 (there are ', nlevs, ' levels)') } } else { oldlevel <- level <- round(level) level <- max(1, min(level, nlevs)) if (oldlevel != level) { warning('level set to: ', level) } } if (lvar == 4) { dim3 <- 3 } else { dim3 <- 4 } } } else if (ndims > 4) { warning(zvar, ' has more than 4 dimensions, I do not know what to do with these data') } ncols <- nc$var[[zvar]]$dim[[dims[1]]]$len nrows <- nc$var[[zvar]]$dim[[dims[2]]]$len xx <- nc$var[[zvar]]$dim[[dims[1]]]$vals rs <- xx[-length(xx)] - xx[-1] if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) { if (is.na(stopIfNotEqualSpaced)) { warning('cells are not equally spaced; you should extract values as points') } else if (stopIfNotEqualSpaced) { stop('cells are not equally spaced; you should extract values as points') } } xrange <- c(min(xx), max(xx)) resx <- (xrange[2] - xrange[1]) / (ncols-1) rm(xx) yy <- nc$var[[zvar]]$dim[[dims[2]]]$vals rs <- yy[-length(yy)] - yy[-1] if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) { if (is.na(stopIfNotEqualSpaced)) { warning('cells are not equally spaced; you should extract values as points') } else if (stopIfNotEqualSpaced) { stop('cells are not equally spaced; you should extract values as points') } } yrange <- c(min(yy), max(yy)) resy <- (yrange[2] - yrange[1]) / (nrows-1) if (yy[1] > yy[length(yy)]) { toptobottom <- FALSE } else { toptobottom <- TRUE } rm(yy) xrange[1] <- xrange[1] - 0.5 * resx xrange[2] <- xrange[2] + 0.5 * resx yrange[1] <- yrange[1] - 0.5 * resy yrange[2] <- yrange[2] + 0.5 * resy long_name <- zvar unit <- '' proj <- NA if (ncdf4) { a <- ncdf4::ncatt_get(nc, zvar, long_name) if (a$hasatt) { long_name <- a$value } a <- ncdf4::ncatt_get(nc, zvar, units) if (a$hasatt) { unit <- a$value } a <- ncdf4::ncatt_get(nc, zvar, grid_mapping) if ( a$hasatt ) { gridmap <- a$value atts <- ncdf4::ncatt_get(nc, gridmap) try(proj <- .getCRSfromGridMap4(atts), silent=TRUE) } else { a <- ncdf4::ncatt_get(nc, zvar, projection_format) if ( a$hasatt ) { projection_format <- a$value if (isTRUE(projection_format == PROJ.4)) { a <- ncdf4::ncatt_get(nc, zvar, projection) if ( a$hasatt ) { proj <- a$value } } } } natest <- ncdf4::ncatt_get(nc, zvar, _FillValue) natest2 <- ncdf4::ncatt_get(nc, zvar, missing_value) } else { a <- ncdf::att.get.ncdf(nc, zvar, long_name) if (a$hasatt) { long_name <- a$value } a <- ncdf::att.get.ncdf(nc, zvar, units) if (a$hasatt) { unit <- a$value } a <- ncdf::att.get.ncdf(nc, zvar, grid_mapping) if ( a$hasatt ) { try(proj <- .getCRSfromGridMap3(nc, a$value), silent=TRUE) } else { a <- ncdf::att.get.ncdf(nc, zvar, projection) if ( a$hasatt ) { projection <- a$value a <- ncdf::att.get.ncdf(nc, zvar, projection_format) if ( a$hasatt ) { projection_format <- a$value if (isTRUE(projection_format == PROJ.4)) { proj <- projection } } } } natest <- ncdf::att.get.ncdf(nc, zvar, _FillValue) natest2 <- ncdf::att.get.ncdf(nc, zvar, missing_value) } if (is.na(proj)) { if (((tolower(substr(nc$var[[zvar]]$dim[[dims[1]]]$name, 1, 3)) == 'lon') & ( tolower(substr(nc$var[[zvar]]$dim[[dims[2]]]$name, 1, 3)) == 'lat' ) ) | ( xrange[1] < -181 | xrange[2] > 181 | yrange[1] < -91 | yrange[2] > 91 )) { proj <- '+proj=longlat +datum=WGS84' } } crs <- .getProj(proj, crs) if (type == 'RasterLayer') { r <- raster(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs) names(r) <- long_name } else if (type == 'RasterBrick') { r <- brick(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs) r@title <- long_name } else if (type == 'RasterQuadBrick') { r <- .quad(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs) r@title <- long_name if (lvar == 4) { dim3 <- 3 step3 <- 4 } else { dim3 <- 4 step3 <- 3 } r@nlevels <- nc$var[[zvar]]$dim[[dim3]]$len r@steps <- nc$var[[zvar]]$dim[[step3]]$len } r@file@name <- filename r@file@toptobottom <- toptobottom r@data@unit <- unit attr(r@data, zvar) <- zvar attr(r@data, dim3) <- dim3 attr(r@data, level) <- level r@file@driver <- netcdf if (natest$hasatt) { r@file@nodatavalue <- as.numeric(natest$value) } else if (natest2$hasatt) { r@file@nodatavalue <- as.numeric(natest2$value) } r@data@fromdisk <- TRUE if (ndims == 2) { nbands = 1 } else { r@file@nbands <- nc$var[[zvar]]$dim[[dim3]]$len r@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals ) if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) { try( r <- .doTime(r, nc, zvar, dim3, ncdf4) ) } else { names(r@z) <- nc$var[[zvar]]$dim[[dim3]]$units } } if (type == 'RasterLayer') { if (is.null(band) | is.na(band)) { if (ndims > 2) { stop(zvar, ' has multiple layers, provide a band value between 1 and ', nc$var[[zvar]]$dim[[dim3]]$len) } } else { if (length(band) > 1) { stop('A RasterLayer can only have a single band. You can use a RasterBrick instead') } if (is.na(band)) { r@data@band <- as.integer(1) } else { band <- as.integer(band) if ( band > nbands(r) ) { stop(paste(band too high. Should be between 1 and, nbands)) } if ( band < 1) { stop(paste(band should be 1 or higher)) } r@data@band <- band } r@z <- list( getZ(r)[r@data@band] ) } } else { #if (length(ndims)== 2) { # stop('cannot make a RasterBrick from data that has only two dimensions (no time step), use raster() instead, and then make a RasterBrick from that') #} r@data@nlayers <- r@file@nbands r@data@min <- rep(Inf, r@file@nbands) r@data@max <- rep(-Inf, r@file@nbands) try( names(r) <- as.character(r@z[[1]]), silent=TRUE ) } return(r) }
170 netCDFtoRasterGMT.R
# Author: Robert J. Hijmans # Date: March 2013 # Version 1.0 # Licence GPL v3 .rasterObjectFromCDF_GMT <- function(nc, ncdf4) { # ncdf4 <- .NCDFversion4() if (ncdf4) { options(rasterNCDF4 = TRUE) # nc <- ncdf4::nc_open(filename) # on.exit( ncdf4::nc_close(nc) ) # conv <- ncdf4::ncatt_get(nc, 0, Conventions) dims <- ncdf4::ncvar_get(nc, dimension, 1) xr <- ncdf4::ncvar_get(nc, x_range, 1) yr <- ncdf4::ncvar_get(nc, y_range, 1) zr <- ncdf4::ncvar_get(nc, z_range, 1) sp <- ncdf4::ncvar_get(nc, spacing, 1) } else { options(rasterNCDF4 = FALSE) # nc <- ncdf::open.ncdf(filename) # on.exit( ncdf::close.ncdf(nc) ) # conv <- ncdf::att.get.ncdf(nc, 0, Conventions) dims <- ncdf::get.var.ncdf(nc, dimension, 1) xr <- ncdf::get.var.ncdf(nc, x_range, 1) yr <- ncdf::get.var.ncdf(nc, y_range, 1) zr <- ncdf::get.var.ncdf(nc, z_range, 1) sp <- ncdf::get.var.ncdf(nc, spacing, 1) } zvar = 'z' #datatype <- .getRasterDTypeFromCDF( nc$var[[zvar]]$prec ) #ncell <- nc$var[[zvar]]$dim[[1]]$len #stopifnot(prod(dims) == ncell) crs <- NA if (xr[1] > -181 & xr[2] < 181 & yr[1] > -91 & yr[2] < 91 ) { crs <- +proj=longlat +datum=WGS84 } dif1 <- abs(((xr[2] - xr[1]) / dims[1]) - sp[2]) dif2 <- abs(((xr[2] - xr[1]) / (dims[1]-1)) - sp[2]) if (dif1 < dif2) { # 30 sec GEBCO data r <- raster(xmn=xr[1], xmx=xr[2], ymn=yr[1], ymx=yr[2], ncol=dims[1], nrow=dims[2], crs=crs) } else { # 1 min data resx <- (xr[2] - xr[1]) / (dims[1]-1) resy <- (yr[2] - yr[1]) / (dims[2]-1) r <- raster(xmn=xr[1]-(0.5*resx), xmx=xr[2]+(0.5*resx), ymn=yr[1]-(0.5*resy), ymx=yr[2]+(0.5*resy), ncol=dims[1], nrow=dims[2], crs=crs) } r@file@name <- nc$filename r@file@toptobottom <- FALSE attr(r@data, zvar) <- zvar attr(r@data, dim3) <- 1 r@file@driver <- netcdf r@data@fromdisk <- TRUE return(r) }
171 netCDFtoStack.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date: Sept 2009 / revised June 2010 # Version 1.0 # Licence GPL v3 .stackCDF <- function(filename, varname='', bands='') { ncdf4 <- .NCDFversion4() if (ncdf4) { nc <- ncdf4::nc_open(filename) on.exit( ncdf4::nc_close(nc) ) } else { nc <- ncdf::open.ncdf(filename) on.exit( ncdf::close.ncdf(nc) ) } zvar <- .varName(nc, varname) dims <- nc$var[[zvar]]$ndims dim3 <- 3 if (dims== 1) { stop('variable only has a single dimension; I cannot make a RasterLayer from this') } else if (dims > 3) { dim3 <- dims warning(zvar, ' has ', dims, ' dimensions, I am using the last one') } else if (dims == 2) { return( stack ( raster(filename, varname=zvar ) ) ) } if (is.null(bands)) { bands <- ''} if (bands[1] == '') { bands = 1 : nc$var[[zvar]]$dim[[dim3]]$len } r <- raster(filename, varname=zvar, band=bands[1]) st <- stack( r ) st@title <- names(r) if (length(bands) > 1) { st@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals[bands] ) names(st@z) <- nc$var[[zvar]]$dim[[dim3]]$units if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) { try( st <- .doTime(st, nc, zvar, dim3, ncdf4) ) } nms <- as.character(st@z[[1]]) st@layers <- lapply(bands, function(x){ r@data@band <- x; r@data@names <- nms[x]; return(r)} ) } return( st ) } #s = .stackCDF(f, varname='uwnd')
172 netCDFutil.R
# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .getCRSfromGridMap3 <- function(nc, gridmap) { m <- matrix(c(grid_mapping_name, +proj, false_easting, +x_0,false_northing, +y_0, scale_factor_at_projection_origin, +k_0, scale_factor_at_central_meridian, +k_0, standard_parallel, +lat_1, standard_parallel1, +lat_1, standard_parallel2, +lat_2, longitude_of_central_meridian, +lon_0, longitude_of_projection_origin, +lon_0, latitude_of_projection_origin, +lat_0, straight_vertical_longitude_from_pole, +lon_0), ncol=2, byrow=TRUE) g <- list() for (i in 1:nrow(m)) { a <- ncdf::att.get.ncdf(nc, gridmap, m[i,1]) if (a$hasatt) { lst <- list(a$value) names(lst) <- m[i,1] g <- c(g, lst) } } .getCRSfromGridMap4(g) } .getCRSfromGridMap4 <- function(g) { # based on info at # http://trac.osgeo.org/gdal/wiki/NetCDF_ProjectionTestingStatus # accessed 7 October 2012 prj <- matrix(c(albers_conical_equal_area, aea, azimuthal_equidistant, aeqd, lambert_cylindrical_equal_area, cea, lambert_azimuthal_equal_area, laea, lambert_conformal_conic, lcc, latitude_longitude, longlat, mercator, merc, orthographic, ortho, polar_stereographic, stere, stereographic, stere, transverse_mercator, tmerc), ncol=2, byrow=TRUE) m <- matrix(c(grid_mapping_name, +proj, false_easting, +x_0,false_northing, +y_0, scale_factor_at_projection_origin, +k_0, scale_factor_at_central_meridian, +k_0, standard_parallel, +lat_1, standard_parallel1, +lat_1, standard_parallel2, +lat_2, longitude_of_central_meridian, +lon_0, longitude_of_projection_origin, +lon_0, latitude_of_projection_origin, +lat_0, straight_vertical_longitude_from_pole, +lon_0, longitude_of_prime_meridian, +lon_0, semi_major_axis, +a, inverse_flattening, +rf), ncol=2, byrow=TRUE) sp <- g$standard_parallel if (!is.null(sp)) { if (length(sp) > 1) { g$standard_parallel1 <- sp[1] g$standard_parallel2 <- sp[2] g$standard_parallel <- NULL } } vals <- unlist(g) vars <- names(g) i <- match(vars, m[,1]) if (any(is.na(i))) { warning(could not process the CRS) print(as.matrix(g)) return(NA) } tab <- cbind(m[i,], vals) j <- match(tab[1,3], prj[,1]) tab[1,3] <- prj[j,2] paste(apply(tab[,2:3], 1, function(x)paste(x, collapse='=')), collapse=' ') } .NCDFversion4 <- function() { loadNCDF <- function() { if (!require(ncdf)) { stop('To open ncdf files, you need to first install package ncdf or ncdf4') } options(rasterNCDF4 = FALSE) return(FALSE) } ncdf4 <- getOption('rasterNCDF4') if (is.null(ncdf4)) { if (length(find.package(ncdf4, quiet=TRUE)) > 0) { if (require(ncdf4, quietly=TRUE)) { options(rasterNCDF4 = TRUE) ncdf4 <- TRUE } else { ncdf4 <- loadNCDF() } } else { ncdf4 <- loadNCDF() } } return(ncdf4) } .isNetCDF <- function(x) { on.exit(options('warn'= getOption('warn'))) options('warn'=-1) fcon <- file(x, rb) tst <- try( w <- readBin(fcon, what='character', n=1), silent=TRUE) close(fcon) if ( isTRUE((substr(w, 1, 3) == CDF ))) { return(TRUE) } else { return(FALSE) } } .getRasterDTypeFromCDF <- function(type) { if (type == char ) { return(INT1U) } else if (type == byte ) { return(INT1S) } else if (type == short ) { return(INT2S) } else if (type == int ) { return(INT4S) } else if (type == integer ) { return(INT4S) } else if (type == float ) { return(FLT4S) } else if (type ==double ) { return(FLT8S) } else { return(FLT4S) } } .getNetCDFDType <- function(dtype) { if (!(dtype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S'))) { stop('not a valid data type') } type <- tolower(.shortDataType(dtype)) size <- dataSize(dtype) * 8 signed <- dataSigned(dtype) if (size == 8) { if (!signed) { return(char) #8-bit characters intended for representing text. } else { return(byte) } } else if (type == 'integer') { if (!signed) { warning('netcdf only stores signed integers') } if (size == 16) { return( short ) } else if (size == 32 ) { return( integer ) } else { return ( double ) } } else { if (size == 32) { return( float ) } else { return ( double ) } } }
173 netCDFwriteCD.R
# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .startWriteCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, att, varname, varunit, varatt, longname, xname, yname, zname, zunit, zatt, NAflag, ...) { ncdf4 <- .NCDFversion4() filename = trim(filename) if (filename == '') { stop('provide a filename') } extension(filename) <- .defaultExtension(format='CDF') if (file.exists(filename) & !overwrite) { stop('file exists, use overwrite=TRUE to overwrite it') } dataType(x) <- datatype datatype <- .getNetCDFDType(datatype) nl <- nlayers(x) if (couldBeLonLat(x)) { if (missing(xname)) xname = 'longitude' if (missing(yname)) yname = 'latitude' xunit = 'degrees_east' yunit = 'degrees_north' } else { if (missing(xname)) xname = 'easting' if (missing(yname)) yname = 'northing' xunit = 'meter' # probably yunit = 'meter' # probably } if (missing(zunit)) { zunit <- 'unknown' } if (missing(zname)) { zname <- 'value' } if (missing(varname)) { if (nl == 1) { varname <- names(x) } else if (!is.null(names(x@z))) { varname <- names(x@z) } else { varname <- 'variable' } } x@title <- varname if (missing(varunit)) varunit <- '' if (missing(longname)) longname <- varname if (ncdf4) { xdim <- ncdf4::ncdim_def( xname, xunit, xFromCol(x, 1:ncol(x)) ) ydim <- ncdf4::ncdim_def( yname, yunit, yFromRow(x, 1:nrow(x)) ) if (inherits(x, 'RasterBrick')) { zv <- 1:nl z <- getZ(x) if (!is.null(z)) { if (!any(is.na(z))) { z <- as.numeric(z) if (!any(is.na(z))) { zv[] <- z } else { warning('z-values cannot be converted to numeric') } } else { warning('z-values contain NA') } } zdim <- ncdf4::ncdim_def( zname, zunit, zv, unlim=TRUE ) vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim,ydim,zdim), NAvalue(x), prec = datatype ) #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim,zdim), -3.4e+38 ) } else { #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim), -3.4e+38 ) vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim,ydim), NAvalue(x), prec = datatype ) } nc <- ncdf4::nc_create(filename, vardef) if (! missing(zatt)){ for (i in 1:length(zatt)) { a <- trim(unlist(strsplit(zatt[i], '='))) ncdf4::ncatt_put(nc, zname, a[1], a[2]) } } if (!missing(NAflag)) { x@file@nodatavalue <- NAflag } ncdf4::ncatt_put(nc, varname, '_FillValue', x@file@nodatavalue) ncdf4::ncatt_put(nc, varname, 'missing_value', x@file@nodatavalue) ncdf4::ncatt_put(nc, varname, 'long_name', longname) proj <- projection(x) if (! is.na(proj)) { ncdf4::ncatt_put(nc, varname, 'projection', proj) ncdf4::ncatt_put(nc, varname, 'projection_format', 'PROJ.4') } if (! missing(varatt)){ for (i in 1:length(varatt)) { a <- trim(unlist(strsplit(varatt[i], '='))) ncdf4::ncatt_put(nc, varname, a[1], a[2]) } } ncdf4::ncatt_put(nc, 0, 'Conventions', 'CF-1.4') if (! missing(att)){ for (i in 1:length(att)) { a <- trim(unlist(strsplit(att[i], '='))) ncdf4::ncatt_put(nc, 0, a[1], a[2]) } } pkgversion <- drop(read.dcf(file=system.file(DESCRIPTION, package='raster'), fields=c(Version))) ncdf4::ncatt_put(nc, 0, 'created_by', paste('R, packages ncdf and raster (version ', pkgversion, ')', sep='')) ncdf4::ncatt_put(nc, 0, 'date', format(Sys.time(), %Y-%m-%d %H:%M:%S)) ncdf4::nc_close(nc) } else { # library(ncdf) xdim <- ncdf::dim.def.ncdf( xname, xunit, xFromCol(x, 1:ncol(x)) ) ydim <- ncdf::dim.def.ncdf( yname, yunit, yFromRow(x, 1:nrow(x)) ) if (inherits(x, 'RasterBrick')) { zv <- 1:nl z <- getZ(x) if (!is.null(z)) { if (!any(is.na(z))) { z <- as.numeric(z) if (!any(is.na(z))) { zv[] <- z } else { warning('z-values cannot be converted to numeric') } } else { warning('z-values contain NA') } } zdim <- ncdf::dim.def.ncdf( zname, zunit, zv, unlim=TRUE ) vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim,zdim), NAvalue(x), prec = datatype ) #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim,zdim), -3.4e+38 ) } else { #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim), -3.4e+38 ) vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim), NAvalue(x), prec = datatype ) } nc <- ncdf::create.ncdf(filename, vardef) if (! missing(zatt)){ for (i in 1:length(zatt)) { a <- trim(unlist(strsplit(zatt[i], '='))) ncdf::att.put.ncdf(nc, zname, a[1], a[2]) } } if (!missing(NAflag)) { x@file@nodatavalue <- NAflag } ncdf::att.put.ncdf(nc, varname, '_FillValue', x@file@nodatavalue) ncdf::att.put.ncdf(nc, varname, 'missing_value', x@file@nodatavalue) ncdf::att.put.ncdf(nc, varname, 'long_name', longname) proj <- projection(x) if (! is.na(proj)) { ncdf::att.put.ncdf(nc, varname, 'projection', proj) ncdf::att.put.ncdf(nc, varname, 'projection_format', 'PROJ.4') } if (! missing(varatt)){ for (i in 1:length(varatt)) { a <- trim(unlist(strsplit(varatt[i], '='))) ncdf::att.put.ncdf(nc, varname, a[1], a[2]) } } ncdf::att.put.ncdf(nc, 0, 'Conventions', 'CF-1.4') if (! missing(att)){ for (i in 1:length(att)) { a <- trim(unlist(strsplit(att[i], '='))) ncdf::att.put.ncdf(nc, 0, a[1], a[2]) } } pkgversion = drop(read.dcf(file=system.file(DESCRIPTION, package='raster'), fields=c(Version))) ncdf::att.put.ncdf(nc, 0, 'created_by', paste('R, packages ncdf and raster (version ', pkgversion, ')', sep='')) ncdf::att.put.ncdf(nc, 0, 'date', format(Sys.time(), %Y-%m-%d %H:%M:%S)) ncdf::close.ncdf(nc) } x@data@min <- rep(Inf, nl) x@data@max <- rep(-Inf, nl) x@data@haveminmax <- FALSE x@file@driver <- 'netcdf' x@file@name <- filename return(x) } .stopWriteCDF <- function(x) { if (getOption('rasterNCDF4')) { nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) ncdf4::ncatt_put(nc, x@title, 'min', as.numeric(x@data@min)) ncdf4::ncatt_put(nc, x@title, 'max', as.numeric(x@data@max)) } else { nc <- ncdf::open.ncdf(x@file@name, write=TRUE) on.exit( ncdf::close.ncdf(nc) ) ncdf::att.put.ncdf(nc, x@title, 'min', as.numeric(x@data@min)) ncdf::att.put.ncdf(nc, x@title, 'max', as.numeric(x@data@max)) } if (inherits(x, 'RasterBrick')) { r <- brick(x@file@name) } else { r <- raster(x@file@name) } return(r) } .writeValuesCDF <- function(x, v, start=1) { rsd <- na.omit(v) if (length(rsd) > 0) { x@data@min <- min(x@data@min, rsd) x@data@max <- max(x@data@max, rsd) } v[is.na(v)] <- x@file@nodatavalue nr <- length(v) / x@ncols v <- matrix(v, ncol=nr) if (getOption('rasterNCDF4')) { nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start), count=c(x@ncols, nr)) ) } else { nc <- ncdf::open.ncdf(x@file@name, write=TRUE) try ( ncdf::put.var.ncdf(nc, x@title, v, start=c(1, start), count=c(x@ncols, nr)) ) ncdf::close.ncdf(nc) } return(x) } .writeValuesBrickCDF <- function(x, v, start=1, layer) { if (missing(layer)) { nl <- nlayers(x) lstart <- 1 lend <- nl w <- getOption('warn') options('warn'=-1) rsd <- apply(v, 2, range, na.rm=TRUE) x@data@min <- pmin(x@data@min, rsd[1,]) x@data@max <- pmax(x@data@max, rsd[2,]) options('warn'= w) } else { nl <- 1 lstart <- layer lend <- layer rsd <- na.omit(v) if (length(rsd) > 0) { x@data@min[layer] <- min(x@data@min[layer], rsd) x@data@max[layer] <- max(x@data@max[layer], rsd) } } ncols <- x@ncols v[is.na(v)] = x@file@nodatavalue rows <- length(v) / (ncols * nl) v <- array(v, c(rows, ncols, nl)) if (getOption('rasterNCDF4')) { nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start, lstart), count=c(ncols, rows, lend) ) ) } else { nc <- ncdf::open.ncdf(x@file@name, write=TRUE) try ( ncdf::put.var.ncdf(nc, x@title, v, start=c(1, start, lstart), count=c(ncols, rows, lend) ) ) ncdf::close.ncdf(nc) } return(x) } #.rasterSaveAsNetCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, ...) { # x <- .startWriteCDF(x, filename=filename, datatype=datatype, overwrite=overwrite, ...) # if (nlayers(x) > 1) { # x <- .writeValuesBrickCDF(x, getValues(x) ) # } else { # x <- .writeValuesCDF(x, getValues(x)) # } # return( .stopWriteCDF(x) ) #} #library(raster) #r = raster(ncol=10, nrow=5) #r[] = c(1:49, NA) #names(r) = 'hello world' #a = .rasterSaveAsNetCDF(r, 'test.nc', overwrite=TRUE) #plot(a) #print(a)
174 newPLot.R
# The functions below here were adapted from the functions in the fields package! (image.plot and subroutines) # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html # Adaptations for the raster package: # Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : May 2010 # Version 1.0 # Licence GPL v3 .plotSpace <- function(asp=1, legend.mar = 3.1, legend.width = 0.5, legend.shrink = 0.5) { par <- par() char.size <- par$cin[1] / par$din[1] offset <- char.size * par$mar[4] legend.width <- char.size * legend.width legend.mar <- legend.mar * char.size legendPlot = par$plt legendPlot[2] <- 1 - legend.mar legendPlot[1] <- legendPlot[2] - legend.width pr <- (legendPlot[4] - legendPlot[3]) * ((1 - legend.shrink)/2) legendPlot[4] <- legendPlot[4] - pr legendPlot[3] <- legendPlot[3] + pr bp <- par$plt bp[2] <- min(bp[2], legendPlot[1] - offset) aspbp = (bp[4]-bp[3]) / (bp[2]-bp[1]) adj = aspbp / asp if (adj < 1) { adjust = (bp[4]-bp[3]) - ((bp[4]-bp[3]) * adj) } else { adjust = (bp[4]-bp[3]) / adj - ((bp[4]-bp[3])) } adjust = adjust / 2 bp bp[3] = bp[3] + adjust bp[4] = bp[4] - adjust bp dp <- legendPlot[2] - legendPlot[1] legendPlot[1] <- min(bp[2] + 0.5 * offset, legendPlot[1]) legendPlot[2] <- legendPlot[1] + dp return(list(legendPlot = legendPlot, mainPlot = bp)) } .plotLegend <- function(z, col, legend.at='classic', lab.breaks = NULL, axis.args = NULL, legend.lab = NULL, legend.args = NULL, ...) { horizontal=FALSE ix <- 1 zlim <- range(z, na.rm = TRUE, finite=TRUE) zrange <- zlim[2]-zlim[1] if (zrange > 10) { decs <- 0 } else if (zrange > 1) { decs <- 1 } else { decs <- ceiling(abs(log10(zrange)) + 1) } pow <- 10^decs minz <- floor(zlim[1] * pow) / pow maxz <- ceiling(zlim[2] * pow) / pow zrange <- maxz - minz nlevel = length(col) binwidth <- c(0, 1:nlevel * (1/nlevel)) iy <- minz + zrange * binwidth # binwidth <- 1 + (maxz - minz)/nlevel # iy <- seq(minz, maxz, by = binwidth) iz <- matrix(iy, nrow = 1, ncol = length(iy)) breaks <- list(...)$breaks if (!is.null(breaks) & !is.null(lab.breaks)) { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args) } else { if (legend.at == 'quantile') { z <- z[is.finite(z)] at = quantile(z, names=F, na.rm=TRUE) axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args) # at <- c(0, 1:5 * (1/5)) # at <- minz + zrange * at } else { at <- axTicks(2, c(minz, maxz, 4)) } at <- round(at, decs) axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args) } if (!horizontal) { if (is.null(breaks)) { image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col = col) } else { image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col = col, breaks = breaks) } } else { if (is.null(breaks)) { image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col) } else { image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, breaks = breaks) } } axis.args = c(axis.args, cex.axis=0.75, tcl=-0.15, list(mgp=c(3, 0.4, 0)) ) do.call(axis, axis.args) #axis(axis.args$side, at=min(iz), las=ifelse(horizontal, 0, 2)) box() # title(main = list(legend.lab, cex=1, font=1)) if (!is.null(legend.lab)) { # mtext(legend.lab, side=3, line=0.75) #legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) legend.args <- list(text = legend.lab, side=3, line=0.75) } if (!is.null(legend.args)) { #do.call(mtext, legend.args) } } .plot2 <- function(x, maxpixels=100000, col=rev(terrain.colors(25)), xlab='', ylab='', asp, box=TRUE, add=FALSE, legend=TRUE, legend.at='', ...) { if (!add & missing(asp)) { if (couldBeLonLat(x)) { ym <- mean(x@extent@ymax + x@extent@ymin) asp <- min(5, 1/cos((ym * pi)/180)) } else { asp = 1 } } plotArea <- .plotSpace(asp) x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) xticks <- axTicks(1, c(xmin(x), xmax(x), 4)) yticks <- axTicks(2, c(ymin(x), ymax(x), 4)) if (xres(x) %% 1 == 0) xticks = round(xticks) if (yres(x) %% 1 == 0) yticks = round(yticks) y <- yFromRow(x, nrow(x):1) z <- t((getValues(x, format='matrix'))[nrow(x):1,]) x <- xFromCol(x,1:ncol(x)) if (add) { image(x=x, y=y, z=z, col=col, axes=FALSE, xlab=xlab, ylab=ylab, add=TRUE, ...) } else { if (legend) { par(pty = m, plt=plotArea$legendPlot, err = -1) .plotLegend(z, col, legend.at=legend.at, ...) par(new=TRUE, plt=plotArea$mainPlot) } image(x=x, y=y, z=z, col=col, axes=FALSE, xlab=xlab, ylab=ylab, asp=asp, ...) axis(1, at=xticks, cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.25, 0)) las = ifelse(max(nchar(as.character(yticks)))> 5, 0, 1) axis(2, at=yticks, las = las, cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.75, 0) ) #axis(3, at=xticks, labels=FALSE, lwd.ticks=0) #axis(4, at=yticks, labels=FALSE, lwd.ticks=0) if (box) box() } } #.plot2(r, legend=T) # .plot2(r, legend.at='quantile') # plot(wrld_simpl, add=T)
175 nlayers.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric(nlayers)) { setGeneric(nlayers, function(x) standardGeneric(nlayers)) } setMethod('nlayers', signature(x='BasicRaster'), function(x){ return(0) } ) setMethod('nlayers', signature(x='Raster'), function(x){ return(1) } ) setMethod('nlayers', signature(x='RasterStack'), function(x){ as.integer( sum(unlist( sapply(x@layers, nlayers) ) ) ) } ) setMethod('nlayers', signature(x='RasterBrick'), function(x){ return(x@data@nlayers) } ) setMethod('nlayers', signature(x='Spatial'), function(x){ if (! is.null( attr(x, 'data') ) ) { return( dim(x@data)[2] ) } else { return( 0 ) } } )
176 notused.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 # Not used .writeRasterAssign <- function(x, filename, ...) { name <- deparse(substitute(x)) x <- writeRaster(x, filename, ...) assign(name, x, envir=parent.frame()) return(invisible()) } .writeSparse <- function(raster, filename, overwrite=FALSE) { # raster@file@driver <- 'raster' if (!overwrite & file.exists(filename)) { stop(filename, exists. Use 'overwrite=TRUE' if you want to overwrite it) } raster@data@values[is.nan(raster@data@values)] <- NA dtype <- .shortDataType(raster@data@datanotation) if (dtype == integer) { raster@data@values <- as.integer(raster@data@values) } if (class(raster@data@values)=='integer') { dataType(raster) <- 'INT4S' } raster <- setMinMax(raster) binraster <- .setFileExtensionValues(raster@file@name, 'raster') raster <- readStart(raster) writeBin( as.vector(raster@data@indices), raster@file@con, size = as.integer(4)) writeBin( as.vector(raster@data@values), raster@file@con, size = dataSize(raster@file@datanotation) ) raster <- readStop(raster) # add the 'sparse' key word to the hdr file!!! hdr(raster) return(raster) }
177 nsidcICE.R
.rasterFromNSIDCFile <- function(x) { ## check name structure ## nt_19781119_f07_v01_s.bin bx <- basename(x) ## test that we can get a date from this ## (as POSIXct so that Z-comparisons are more natural) dts <- as.POSIXct(basename(x), format = nt_%Y%m%d, tz = GMT) ## test that we see _f and _v fyes <- tolower(substr(bx, 13L, 13L)) %in% c(f, n) vyes <- tolower(substr(bx, 17L, 17L)) %in% c(v, n) ## finally, it's north or south hemi <- tolower(substr(bx, 21L, 21L)) hyes <- hemi %in% c(s, n) if(!(!is.na(dts) & fyes & vyes & hyes)) return(NULL) ## NSIDC projection and grid size ## https://nsidc.org/data/polar_stereo/ps_grids.html ## http://spatialreference.org/ref/?search=nsidc ## Hughes 1980 ellipsoid, True Scale Lat is +/-70 if (hemi == s) { prj <- +proj=stere +lat_0=-90 +lat_ts=-70 +lon_0=0 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs dims <- c(316L, 332L) ext <- c(-3950000, 3950000, -3950000, 4350000) } else { ## northern hemisphere prj <- +proj=stere +lat_0=90 +lat_ts=70 +lon_0=-45 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs dims <- c(304, 448) ext <- c(-3837500, 3762500, -5362500, 5837500) } on.exit(close(con)) con <- file(x, open = rb) ## chuck the header try1 <- try(trash <- readBin(con, integer, size = 1, n = 300)) ## TODO: warnings that we thought it was NSIDC, but it did not work? if (inherits(try1, try-error)) return(NULL) dat <- try(readBin(con, integer, size = 1, n = prod(dims), endian = little, signed = FALSE)) if (inherits(dat, try-error)) return(NULL) r100 <- dat > 250 r0 <- dat < 1 ## if (rescale) { dat <- dat/2.5 ## rescale back to 100 ## } ## if (setNA) { dat[r100] <- NA dat[r0] <- NA ## } r <- raster(t(matrix(dat, dims[1])), xmn=ext[1], xmx=ext[2], ymn=ext[3], ymx=ext[4], crs = prj) setZ(r, dts, name = time) }
178 origin.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : October 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric(origin)) { setGeneric(origin, function(x, ...) standardGeneric(origin)) } setMethod('origin', signature(x='BasicRaster'), function(x, ...) { e <- x@extent r <- res(x) x <- e@xmin - r[1]*(round(e@xmin / r[1])) y <- e@ymax - r[2]*(round(e@ymax / r[2])) if (isTRUE(all.equal((r[1] + x), abs(x)))) { x <- abs(x) } if (isTRUE(all.equal((r[2] + y), abs(y)))) { y <- abs(y) } return(c(x, y)) } ) if (!isGeneric(origin<-)) { setGeneric(origin<-, function(x, value) standardGeneric(origin<-)) } setMethod(origin<-, signature('BasicRaster'), function(x, value) { value <- rep(value, length.out=2) dif <- value - origin(x) res <- res(x) dif[1] <- dif[1] %% res[1] dif[2] <- dif[2] %% res[2] for (i in 1:2) { if (dif[i] < 0) { if ((dif[i] + res[i]) < abs(dif[i])) { dif[i] <- dif[i] + res[i] } } else { if (abs(dif[i] - res[i]) < dif[i]) { dif[i] <- dif[i] - res[i] } } } e <- extent(x) e@xmin <- e@xmin + dif[1] e@xmax <- e@xmax + dif[1] e@ymin <- e@ymin + dif[2] e@ymax <- e@ymax + dif[2] x@extent <- e return(x) } )
179 overlay.R
# Author: Robert J. Hijmans, r.hijmans@gmail.com # Date : June 2008 # Version 0.9 # Licence GPL v3 # version 1, April 2012 setMethod('overlay', signature(x='Raster', y='Raster'), function(x, y, ..., fun, filename=, recycle=TRUE){ if (missing(fun)) { stop(you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum') } lst <- list(...) isRast <- sapply(lst, function(x) inherits(x, 'Raster')) if (sum(unlist(isRast)) > 0) { x <- c(x, y, lst[isRast]) lst <- lst[! isRast ] } else { x <- list(x, y) } lst$fun <- fun lst$filename <- filename lst$recycle <- recycle lst$x <- x do.call(.overlayList, lst) } ) setMethod('overlay', signature(x='Raster', y='missing'), function(x, y, ..., fun, filename=, unstack=TRUE){ if (missing(fun)) { stop(you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum') } x <- .makeRasterList(x, unstack=unstack) .overlayList(x, fun=fun, filename=filename, ...) } ) .overlayList <- function(x, fun, filename=, recycle=TRUE, ...){ ln <- length(x) if (ln < 1) { stop('no Rasters') } if (ln > 2) { compareRaster(x) } nl <- sapply(x, nlayers) maxnl <- max(nl) filename <- trim(filename) testmat <- NULL testlst <- vector(length=length(x), mode='list') w <- getOption('warn') options('warn'=-1) for (i in 1:length(testlst)) { v <- extract(x[[i]], 1:5) testmat <- cbind(testmat, as.vector(v)) testlst[[i]] <- v } options('warn'= w) test1 <- try ( apply(testmat, 1, fun) , silent=TRUE ) if (class(test1) != try-error) { doapply <- TRUE if (! is.null(dim(test1))) { test1 <- t(test1) } else { test1 <- matrix(test1, ncol=maxnl) } nlout <- NCOL(test1) } else { doapply <- FALSE dovec <- FALSE test2 <- try ( do.call(fun, testlst), silent=TRUE ) nlout <- length(test2)/5 if (class(test2) == try-error | length(test2) < 5) { dovec <- TRUE testlst <- lapply(testlst, as.vector) test3 <- try ( do.call(fun, testlst), silent=TRUE ) nlout <- length(test3)/5 if (class(test3) == try-error | length(test3) < 5) { stop('cannot use this formula, probably because it is not vectorized') } } } if (nlout == 1) { out <- raster(x[[1]]) } else { out <- brick(x[[1]], values=FALSE, nl=nlout) } if ( canProcessInMemory(out, sum(nl)+maxnl) ) { pb <- pbCreate(3, label='overlay', ...) pbStep(pb, 1) if (doapply) { valmat <- matrix(nrow=ncell(out)*maxnl, ncol=length(x)) for (i in 1:length(x)) { if (ncell(x[[i]]) < nrow(valmat)) { options('warn'=-1) valmat[,i] <- as.vector(getValues(x[[i]])) * rep(1, nrow(valmat)) options('warn'= w) } else { valmat[,i] <- as.vector(getValues(x[[i]])) } } pbStep(pb, 2) vals <- apply(valmat, 1, fun) if (! is.null(dim(vals))) { vals <- t(vals) } vals <- matrix(vals, nrow=ncell(out)) } else { for (i in 1:length(x)) { x[[i]] <- getValues(x[[i]]) } if (dovec) { x <- lapply(x, as.vector) } pbStep(pb, 2) vals <- do.call(fun, x) vals <- matrix(vals, nrow=ncell(out)) } pbStep(pb, 3) out <- setValues(out, vals) if (filename != ) { out <- writeRaster(out, filename=filename, ...) } pbClose(pb) return(out) } else { if (filename == ) { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=sum(nl)+maxnl) pb <- pbCreate(tr$n, label='overlay', ...) if (doapply) { valmat = matrix(nrow=tr$nrows[1]*ncol(out)*maxnl, ncol=length(x)) for (i in 1:tr$n) { if (i == tr$n) { valmat = matrix(nrow=tr$nrows[i]*ncol(out)*maxnl , ncol=length(x)) } for (j in 1:length(x)) { v <- as.vector(getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i])) if (length(v) < nrow(valmat)) { options('warn'=-1) valmat[,j] <- v * rep(1, nrow(valmat)) options('warn'=w) } else { valmat[,j] <- v } } vv <- apply(valmat, 1, fun) if (! is.null(dim(vv))) { vals <- t(vv) } vv <- matrix(vv, ncol=nlout) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } } else { vallist <- list() for (i in 1:tr$n) { if (dovec) { for (j in 1:length(x)) { vallist[[j]] <- as.vector( getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]) ) } } else { for (j in 1:length(x)) { vallist[[j]] <- getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]) } } vv <- do.call(fun, vallist) vv <- matrix(vv, ncol=nlout) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) } return(out) }